ByteString Ref continued
Several nice speed wins I think. At 340/633 files converted.
This commit is contained in:
Joey Hess
parent
d5d8259937
commit
6c81e0c8f1
16 changed files with 124 additions and 99 deletions
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.AdjustedBranch.Name (
|
||||
originalToAdjusted,
|
||||
adjustedToOriginal,
|
||||
|
|
@ -18,14 +20,15 @@ import qualified Git.Ref
|
|||
import Utility.Misc
|
||||
|
||||
import Control.Applicative
|
||||
import Data.List
|
||||
import Data.Char
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
adjustedBranchPrefix :: String
|
||||
adjustedBranchPrefix :: S.ByteString
|
||||
adjustedBranchPrefix = "refs/heads/adjusted/"
|
||||
|
||||
class SerializeAdjustment t where
|
||||
serializeAdjustment :: t -> String
|
||||
deserializeAdjustment :: String -> Maybe t
|
||||
serializeAdjustment :: t -> S.ByteString
|
||||
deserializeAdjustment :: S.ByteString -> Maybe t
|
||||
|
||||
instance SerializeAdjustment Adjustment where
|
||||
serializeAdjustment (LinkAdjustment l) =
|
||||
|
|
@ -33,7 +36,7 @@ instance SerializeAdjustment Adjustment where
|
|||
serializeAdjustment (PresenceAdjustment p Nothing) =
|
||||
serializeAdjustment p
|
||||
serializeAdjustment (PresenceAdjustment p (Just l)) =
|
||||
serializeAdjustment p ++ "-" ++ serializeAdjustment l
|
||||
serializeAdjustment p <> "-" <> serializeAdjustment l
|
||||
deserializeAdjustment s =
|
||||
(LinkAdjustment <$> deserializeAdjustment s)
|
||||
<|>
|
||||
|
|
@ -41,7 +44,7 @@ instance SerializeAdjustment Adjustment where
|
|||
<|>
|
||||
(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing)
|
||||
where
|
||||
(s1, s2) = separate (== '-') s
|
||||
(s1, s2) = separate' (== (fromIntegral (ord '-'))) s
|
||||
|
||||
instance SerializeAdjustment LinkAdjustment where
|
||||
serializeAdjustment UnlockAdjustment = "unlocked"
|
||||
|
|
@ -65,19 +68,21 @@ newtype AdjBranch = AdjBranch { adjBranch :: Branch }
|
|||
|
||||
originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
|
||||
originalToAdjusted orig adj = AdjBranch $ Ref $
|
||||
adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")"
|
||||
adjustedBranchPrefix <> base <> "(" <> serializeAdjustment adj <> ")"
|
||||
where
|
||||
base = fromRef (Git.Ref.base orig)
|
||||
base = fromRef' (Git.Ref.base orig)
|
||||
|
||||
type OrigBranch = Branch
|
||||
|
||||
adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)
|
||||
adjustedToOriginal b
|
||||
| adjustedBranchPrefix `isPrefixOf` bs = do
|
||||
let (base, as) = separate (== '(') (drop prefixlen bs)
|
||||
adj <- deserializeAdjustment (takeWhile (/= ')') as)
|
||||
| adjustedBranchPrefix `S.isPrefixOf` bs = do
|
||||
let (base, as) = separate' (== openparen) (S.drop prefixlen bs)
|
||||
adj <- deserializeAdjustment (S.takeWhile (/= closeparen) as)
|
||||
Just (adj, Git.Ref.branchRef (Ref base))
|
||||
| otherwise = Nothing
|
||||
where
|
||||
bs = fromRef b
|
||||
prefixlen = length adjustedBranchPrefix
|
||||
bs = fromRef' b
|
||||
prefixlen = S.length adjustedBranchPrefix
|
||||
openparen = fromIntegral (ord '(')
|
||||
closeparen = fromIntegral (ord ')')
|
||||
|
|
|
|||
|
|
@ -29,7 +29,9 @@ module Annex.Branch (
|
|||
withIndex,
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import Data.Function
|
||||
|
|
@ -643,11 +645,11 @@ getMergedRefs = S.fromList . map fst <$> getMergedRefs'
|
|||
getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
|
||||
getMergedRefs' = do
|
||||
f <- fromRepo gitAnnexMergedRefs
|
||||
s <- liftIO $ catchDefaultIO "" $ readFile f
|
||||
return $ map parse $ lines s
|
||||
s <- liftIO $ catchDefaultIO mempty $ B.readFile f
|
||||
return $ map parse $ B8.lines s
|
||||
where
|
||||
parse l =
|
||||
let (s, b) = separate (== '\t') l
|
||||
let (s, b) = separate' (== (fromIntegral (ord '\t'))) l
|
||||
in (Ref s, Ref b)
|
||||
|
||||
{- Grafts a treeish into the branch at the specified location,
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
|
@ -24,13 +24,14 @@ import qualified Utility.SimpleProtocol as Proto
|
|||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TBMChan
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
newtype ChangedRefs = ChangedRefs [Git.Ref]
|
||||
deriving (Show)
|
||||
|
||||
instance Proto.Serializable ChangedRefs where
|
||||
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)
|
||||
|
||||
|
|
@ -97,7 +98,7 @@ notifyHook chan reffile _
|
|||
| ".lock" `isSuffixOf` reffile = noop
|
||||
| otherwise = void $ do
|
||||
sha <- catchDefaultIO Nothing $
|
||||
extractSha <$> readFile reffile
|
||||
extractSha <$> S.readFile reffile
|
||||
-- When the channel is full, there is probably no reader
|
||||
-- running, or ref changes have been occuring very fast,
|
||||
-- so it's ok to not write the change to it.
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Database.Keys (
|
||||
DbHandle,
|
||||
|
|
@ -44,6 +45,7 @@ import Git.Types
|
|||
import Git.Index
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
{- Runs an action that reads from the database.
|
||||
|
|
@ -237,8 +239,8 @@ reconcileStaged qh = do
|
|||
Nothing -> noop
|
||||
where
|
||||
go cur indexcache = do
|
||||
(l, cleanup) <- inRepo $ pipeNullSplit diff
|
||||
changed <- procdiff (map decodeBL' l) False
|
||||
(l, cleanup) <- inRepo $ pipeNullSplit' diff
|
||||
changed <- procdiff l False
|
||||
void $ liftIO cleanup
|
||||
-- Flush database changes immediately
|
||||
-- so other processes can see them.
|
||||
|
|
@ -278,15 +280,16 @@ reconcileStaged qh = do
|
|||
, Param "--no-ext-diff"
|
||||
]
|
||||
|
||||
procdiff (info:file:rest) changed = case words info of
|
||||
((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])
|
||||
-- Only want files, not symlinks
|
||||
| dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do
|
||||
maybe noop (reconcile (asTopFilePath (toRawFilePath file)))
|
||||
=<< catKey (Ref dstsha)
|
||||
procdiff rest True
|
||||
| otherwise -> procdiff rest changed
|
||||
_ -> return changed -- parse failed
|
||||
procdiff (info:file:rest) changed
|
||||
| ":" `S.isPrefixOf` info = case S8.words info of
|
||||
(_colonsrcmode:dstmode:_srcsha:dstsha:_change:[])
|
||||
-- Only want files, not symlinks
|
||||
| dstmode /= fmtTreeItemType TreeSymlink -> do
|
||||
maybe noop (reconcile (asTopFilePath file))
|
||||
=<< catKey (Ref dstsha)
|
||||
procdiff rest True
|
||||
| otherwise -> procdiff rest changed
|
||||
_ -> return changed -- parse failed
|
||||
procdiff _ changed = return changed
|
||||
|
||||
-- Note that database writes done in here will not necessarily
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ import qualified Git.Config
|
|||
import qualified Git.Ref
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
|
||||
{- The currently checked out branch.
|
||||
-
|
||||
|
|
@ -39,25 +40,27 @@ current r = do
|
|||
|
||||
{- The current branch, which may not really exist yet. -}
|
||||
currentUnsafe :: Repo -> IO (Maybe Branch)
|
||||
currentUnsafe r = parse . firstLine'
|
||||
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
|
||||
currentUnsafe r = parse . firstLine' <$> pipeReadStrict
|
||||
[ Param "symbolic-ref"
|
||||
, Param "-q"
|
||||
, Param $ fromRef Git.Ref.headRef
|
||||
] r
|
||||
where
|
||||
parse b
|
||||
| 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
|
||||
- branch. -}
|
||||
changed :: Branch -> Branch -> Repo -> IO Bool
|
||||
changed origbranch newbranch repo
|
||||
| origbranch == newbranch = return False
|
||||
| otherwise = not . null
|
||||
| otherwise = not . B.null
|
||||
<$> changed' origbranch newbranch [Param "-n1"] repo
|
||||
where
|
||||
|
||||
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
|
||||
changed' origbranch newbranch extraps repo =
|
||||
decodeBS <$> pipeReadStrict ps repo
|
||||
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString
|
||||
changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
|
||||
where
|
||||
ps =
|
||||
[ 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. -}
|
||||
changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha]
|
||||
changedCommits origbranch newbranch extraps repo =
|
||||
catMaybes . map extractSha . lines
|
||||
catMaybes . map extractSha . B8.lines
|
||||
<$> changed' origbranch newbranch extraps repo
|
||||
|
||||
{- 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 allowempty message branch parentrefs repo = do
|
||||
tree <- getSha "write-tree" $
|
||||
decodeBS' <$> pipeReadStrict [Param "write-tree"] repo
|
||||
tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo
|
||||
ifM (cancommit tree)
|
||||
( do
|
||||
sha <- commitTree commitmode message parentrefs tree repo
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Git.CatFile (
|
||||
CatFileHandle,
|
||||
catFileStart,
|
||||
|
|
@ -22,7 +24,6 @@ module Git.CatFile (
|
|||
import System.IO
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import qualified Data.Map as M
|
||||
import Data.String
|
||||
import Data.Char
|
||||
|
|
@ -69,11 +70,11 @@ catFileStop h = do
|
|||
{- Reads a file from a specified branch. -}
|
||||
catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
|
||||
catFile h branch file = catObject h $ Ref $
|
||||
fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
|
||||
fromRef' branch <> ":" <> toInternalGitPath file
|
||||
|
||||
catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
|
||||
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.
|
||||
- Objects that do not exist will have "" returned. -}
|
||||
|
|
@ -148,7 +149,7 @@ parseResp object l
|
|||
| " missing" `isSuffixOf` l -- less expensive than full check
|
||||
&& l == fromRef object ++ " missing" = Just DNE
|
||||
| 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 t, [(bytes, "")]) ->
|
||||
Just $ ParsedResp sha' bytes t
|
||||
|
|
@ -218,39 +219,39 @@ catTree h treeref = go <$> catObjectDetails h treeref
|
|||
catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit)
|
||||
catCommit h commitref = go <$> catObjectDetails h commitref
|
||||
where
|
||||
go (Just (b, _, CommitObject)) = parseCommit b
|
||||
go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b)
|
||||
go _ = Nothing
|
||||
|
||||
parseCommit :: L.ByteString -> Maybe Commit
|
||||
parseCommit :: S.ByteString -> Maybe Commit
|
||||
parseCommit b = Commit
|
||||
<$> (extractSha . L8.unpack =<< field "tree")
|
||||
<*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))
|
||||
<$> (extractSha =<< field "tree")
|
||||
<*> Just (maybe [] (mapMaybe extractSha) (fields "parent"))
|
||||
<*> (parsemetadata <$> field "author")
|
||||
<*> (parsemetadata <$> field "committer")
|
||||
<*> Just (L8.unpack $ L.intercalate (L.singleton nl) message)
|
||||
<*> Just (decodeBS $ S.intercalate (S.singleton nl) message)
|
||||
where
|
||||
field n = headMaybe =<< fields n
|
||||
fields n = M.lookup (fromString n) fieldmap
|
||||
fieldmap = M.fromListWith (++) ((map breakfield) header)
|
||||
breakfield l =
|
||||
let (k, sp_v) = L.break (== sp) l
|
||||
in (k, [L.drop 1 sp_v])
|
||||
(header, message) = separate L.null ls
|
||||
ls = L.split nl b
|
||||
let (k, sp_v) = S.break (== sp) l
|
||||
in (k, [S.drop 1 sp_v])
|
||||
(header, message) = separate S.null ls
|
||||
ls = S.split nl b
|
||||
|
||||
-- author and committer lines have the form: "name <email> date"
|
||||
-- The email is always present, even if empty "<>"
|
||||
parsemetadata l = CommitMetaData
|
||||
{ commitName = whenset $ L.init name_sp
|
||||
{ commitName = whenset $ S.init name_sp
|
||||
, commitEmail = whenset email
|
||||
, commitDate = whenset $ L.drop 2 gt_sp_date
|
||||
, commitDate = whenset $ S.drop 2 gt_sp_date
|
||||
}
|
||||
where
|
||||
(name_sp, rest) = L.break (== lt) l
|
||||
(email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)
|
||||
(name_sp, rest) = S.break (== lt) l
|
||||
(email, gt_sp_date) = S.break (== gt) (S.drop 1 rest)
|
||||
whenset v
|
||||
| L.null v = Nothing
|
||||
| otherwise = Just (L8.unpack v)
|
||||
| S.null v = Nothing
|
||||
| otherwise = Just (decodeBS v)
|
||||
|
||||
nl = fromIntegral (ord '\n')
|
||||
sp = fromIntegral (ord ' ')
|
||||
|
|
|
|||
|
|
@ -16,8 +16,8 @@ import Git.Sha
|
|||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
|
||||
data History t = History t (S.Set (History t))
|
||||
deriving (Show, Eq, Ord)
|
||||
|
|
@ -56,8 +56,8 @@ getHistoryToDepth n commit r = do
|
|||
!h <- fmap (truncateHistoryToDepth n)
|
||||
. build Nothing
|
||||
. map parsehistorycommit
|
||||
. map B.copy
|
||||
. B8.lines
|
||||
. map L.toStrict
|
||||
. L8.lines
|
||||
<$> L.hGetContents inh
|
||||
hClose inh
|
||||
void $ waitForProcess pid
|
||||
|
|
@ -97,7 +97,7 @@ getHistoryToDepth n commit r = do
|
|||
, 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 $
|
||||
( HistoryCommit
|
||||
{ historyCommit = c
|
||||
|
|
|
|||
|
|
@ -36,9 +36,10 @@ import Utility.InodeCache
|
|||
import Utility.TimeStamp
|
||||
|
||||
import Numeric
|
||||
import Data.Char
|
||||
import System.Posix.Types
|
||||
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.
|
||||
-
|
||||
|
|
@ -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
|
||||
- branch. -}
|
||||
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. -}
|
||||
notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
|
||||
|
|
@ -189,21 +190,21 @@ stagedDetails = stagedDetails' []
|
|||
- contents. -}
|
||||
stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
|
||||
stagedDetails' ps l repo = guardSafeForLsFiles repo $ do
|
||||
(ls, cleanup) <- pipeNullSplit params repo
|
||||
(ls, cleanup) <- pipeNullSplit' params repo
|
||||
return (map parseStagedDetails ls, cleanup)
|
||||
where
|
||||
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
|
||||
Param "--" : map (File . fromRawFilePath) l
|
||||
|
||||
parseStagedDetails :: L.ByteString -> StagedDetails
|
||||
parseStagedDetails :: S.ByteString -> StagedDetails
|
||||
parseStagedDetails s
|
||||
| null file = (L.toStrict s, Nothing, Nothing)
|
||||
| otherwise = (toRawFilePath file, extractSha sha, readmode mode)
|
||||
| S.null file = (s, Nothing, Nothing)
|
||||
| otherwise = (file, extractSha sha, readmode mode)
|
||||
where
|
||||
(metadata, file) = separate (== '\t') (decodeBL' s)
|
||||
(mode, metadata') = separate (== ' ') metadata
|
||||
(sha, _) = separate (== ' ') metadata'
|
||||
readmode = fst <$$> headMaybe . readOct
|
||||
(metadata, file) = separate' (== fromIntegral (ord '\t')) s
|
||||
(mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata
|
||||
(sha, _) = separate' (== fromIntegral (ord ' ')) metadata'
|
||||
readmode = fst <$$> headMaybe . readOct . decodeBS'
|
||||
|
||||
{- Returns a list of the files in the specified locations that are staged
|
||||
- for commit, and whose type has changed. -}
|
||||
|
|
|
|||
|
|
@ -232,7 +232,7 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
|
|||
getAllRefs' :: FilePath -> IO [Ref]
|
||||
getAllRefs' refdir = do
|
||||
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
|
||||
|
||||
explodePackedRefsFile :: Repo -> IO ()
|
||||
|
|
@ -257,8 +257,8 @@ packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
|
|||
parsePacked :: String -> Maybe (Sha, Ref)
|
||||
parsePacked l = case words l of
|
||||
(sha:ref:[])
|
||||
| isJust (extractSha sha) && Ref.legal True ref ->
|
||||
Just (Ref sha, Ref ref)
|
||||
| isJust (extractSha (encodeBS' sha)) && Ref.legal True ref ->
|
||||
Just (Ref (encodeBS' sha), Ref (encodeBS' ref))
|
||||
_ -> Nothing
|
||||
|
||||
{- 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
|
||||
then return (Just branch, goodcommits')
|
||||
else do
|
||||
(ls, cleanup) <- pipeNullSplit
|
||||
(ls, cleanup) <- pipeNullSplit'
|
||||
[ Param "log"
|
||||
, Param "-z"
|
||||
, Param "--format=%H"
|
||||
, Param (fromRef branch)
|
||||
] r
|
||||
let branchshas = catMaybes $ map (extractSha . decodeBL) ls
|
||||
let branchshas = catMaybes $ map extractSha ls
|
||||
reflogshas <- RefLog.get branch r
|
||||
-- XXX Could try a bit harder here, and look
|
||||
-- for uncorrupted old commits in branches in the
|
||||
|
|
@ -328,8 +328,8 @@ verifyCommit missing goodcommits commit r
|
|||
where
|
||||
parse l = case words l of
|
||||
(commitsha:treesha:[]) -> (,)
|
||||
<$> extractSha commitsha
|
||||
<*> extractSha treesha
|
||||
<$> extractSha (encodeBS' commitsha)
|
||||
<*> extractSha (encodeBS' treesha)
|
||||
_ -> Nothing
|
||||
check [] = return True
|
||||
check ((c, t):rest)
|
||||
|
|
@ -448,7 +448,8 @@ preRepair g = do
|
|||
void $ tryIO $ allowWrite f
|
||||
where
|
||||
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. -}
|
||||
runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ import System.Posix.Types
|
|||
import Control.Monad.IO.Class
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
||||
newtype Tree = Tree [TreeContent]
|
||||
deriving (Show)
|
||||
|
|
@ -106,7 +107,7 @@ mkTree (MkTreeHandle cp) l = CoProcess.query cp send receive
|
|||
NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"
|
||||
TreeCommit f fm s -> mkTreeOutput fm CommitObject s f
|
||||
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 = 0o040000
|
||||
|
|
|
|||
|
|
@ -10,8 +10,10 @@ module Git.UnionMerge (
|
|||
mergeIndex
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Common
|
||||
|
|
@ -54,13 +56,13 @@ mergeIndex hashhandle ch repo bs = forM_ bs $ \b ->
|
|||
|
||||
{- For merging two trees. -}
|
||||
mergeTrees :: Ref -> Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer
|
||||
mergeTrees (Ref x) (Ref y) hashhandle ch = doMerge hashhandle ch
|
||||
("diff-tree":diffOpts ++ [x, y, "--"])
|
||||
mergeTrees x y hashhandle ch = doMerge hashhandle ch
|
||||
("diff-tree":diffOpts ++ [fromRef x, fromRef y, "--"])
|
||||
|
||||
{- For merging a single tree into the index. -}
|
||||
mergeTreeIndex :: Ref -> HashObjectHandle -> CatFileHandle -> Repo -> Streamer
|
||||
mergeTreeIndex (Ref r) hashhandle ch = doMerge hashhandle ch $
|
||||
"diff-index" : diffOpts ++ ["--cached", r, "--"]
|
||||
mergeTreeIndex r hashhandle ch = doMerge hashhandle ch $
|
||||
"diff-index" : diffOpts ++ ["--cached", fromRef r, "--"]
|
||||
|
||||
diffOpts :: [String]
|
||||
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. -}
|
||||
doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer
|
||||
doMerge hashhandle ch differ repo streamer = do
|
||||
(diff, cleanup) <- pipeNullSplit (map Param differ) repo
|
||||
(diff, cleanup) <- pipeNullSplit' (map Param differ) repo
|
||||
go diff
|
||||
void $ cleanup
|
||||
where
|
||||
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)
|
||||
go (_:[]) = error $ "parse error " ++ show differ
|
||||
|
||||
{- 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
|
||||
- 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
|
||||
[] -> return Nothing
|
||||
(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)
|
||||
=<< calcMerge . zip shas <$> mapM getcontents shas
|
||||
where
|
||||
[_colonmode, _bmode, asha, bsha, _status] = words info
|
||||
[_colonmode, _bmode, asha, bsha, _status] = S8.words info
|
||||
use sha = return $ Just $
|
||||
updateIndexLine sha TreeFile $ asTopFilePath file
|
||||
-- Get file and split into lines to union merge.
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ readFsckResults u = do
|
|||
deserialize ("truncated":ls) = deserialize' ls True
|
||||
deserialize ls = deserialize' ls False
|
||||
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
|
||||
|
||||
clearFsckResults :: UUID -> Annex ()
|
||||
|
|
|
|||
16
Logs/View.hs
16
Logs/View.hs
|
|
@ -9,6 +9,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Logs.View (
|
||||
currentView,
|
||||
setView,
|
||||
|
|
@ -31,6 +33,7 @@ import Logs.File
|
|||
import qualified Data.Text as T
|
||||
import qualified Data.Set as S
|
||||
import Data.Char
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
setView :: View -> Annex ()
|
||||
setView v = do
|
||||
|
|
@ -54,11 +57,11 @@ recentViews = do
|
|||
currentView :: Annex (Maybe View)
|
||||
currentView = go =<< inRepo Git.Branch.current
|
||||
where
|
||||
go (Just b) | branchViewPrefix `isPrefixOf` fromRef b =
|
||||
go (Just b) | branchViewPrefix `B.isPrefixOf` fromRef' b =
|
||||
headMaybe . filter (\v -> branchView v == b) <$> recentViews
|
||||
go _ = return Nothing
|
||||
|
||||
branchViewPrefix :: String
|
||||
branchViewPrefix :: B.ByteString
|
||||
branchViewPrefix = "refs/heads/views"
|
||||
|
||||
{- Generates a git branch name for a View.
|
||||
|
|
@ -68,10 +71,11 @@ branchViewPrefix = "refs/heads/views"
|
|||
-}
|
||||
branchView :: View -> Git.Branch
|
||||
branchView view
|
||||
| null name = Git.Ref branchViewPrefix
|
||||
| otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name
|
||||
| B.null name = Git.Ref branchViewPrefix
|
||||
| otherwise = Git.Ref $ branchViewPrefix <> "/" <> name
|
||||
where
|
||||
name = intercalate ";" $ map branchcomp (viewComponents view)
|
||||
name = encodeBS' $
|
||||
intercalate ";" $ map branchcomp (viewComponents view)
|
||||
branchcomp c
|
||||
| viewVisible c = branchcomp' c
|
||||
| otherwise = "(" ++ branchcomp' c ++ ")"
|
||||
|
|
@ -92,7 +96,7 @@ branchView view
|
|||
is_branchView :: Git.Branch -> Bool
|
||||
is_branchView (Ref b)
|
||||
| b == branchViewPrefix = True
|
||||
| otherwise = (branchViewPrefix ++ "/") `isPrefixOf` b
|
||||
| otherwise = (branchViewPrefix <> "/") `B.isPrefixOf` b
|
||||
|
||||
prop_branchView_legal :: View -> Bool
|
||||
prop_branchView_legal = Git.Ref.legal False . fromRef . branchView
|
||||
|
|
|
|||
|
|
@ -343,7 +343,7 @@ extractRemoteGitConfig r remotename = do
|
|||
, remoteAnnexReadOnly = getbool "readonly" False
|
||||
, remoteAnnexCheckUUID = getbool "checkuuid" True
|
||||
, remoteAnnexVerify = getbool "verify" True
|
||||
, remoteAnnexTrackingBranch = Git.Ref <$>
|
||||
, remoteAnnexTrackingBranch = Git.Ref . encodeBS <$>
|
||||
( notempty (getmaybe "tracking-branch")
|
||||
<|> notempty (getmaybe "export-tracking") -- old name
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Types.View where
|
||||
|
||||
import Annex.Common
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ setIndirect = do
|
|||
fromDirectBranch :: Ref -> Ref
|
||||
fromDirectBranch directhead = case splitc '/' $ fromRef directhead of
|
||||
("refs":"heads":"annex":"direct":rest) ->
|
||||
Ref $ "refs/heads/" ++ intercalate "/" rest
|
||||
Ref $ encodeBS' $ "refs/heads/" ++ intercalate "/" rest
|
||||
_ -> directhead
|
||||
|
||||
switchHEADBack :: Annex ()
|
||||
|
|
|
|||
Loading…
Reference in a new issue