mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'bytestring-ref'

Browse source
This commit is contained in:
Joey Hess 2020-04-08 14:10:24 -04:00
commit 89c3b20695
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
55 changed files with 329 additions and 226 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Annex/AdjustedBranch.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Annex.AdjustedBranch (
Adjustment(..),
@ -61,6 +61,7 @@ import qualified Database.Keys
import Config
import qualified Data.Map as M
import qualified Data.ByteString as S
-- How to perform various adjustments to a TreeItem.
class AdjustTreeItem t where
@ -128,7 +129,7 @@ newtype BasisBranch = BasisBranch Ref
-- refs/basis/adjusted/master(unlocked).
basisBranch :: AdjBranch -> BasisBranch
basisBranch (AdjBranch adjbranch) = BasisBranch $
Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch))
Ref ("refs/basis/" <> fromRef' (Git.Ref.base adjbranch))
getAdjustment :: Branch -> Maybe Adjustment
getAdjustment = fmap fst . adjustedToOriginal
@ -405,7 +406,8 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
<||> (resolveMerge (Just updatedorig) tomerge True <&&> commitResolvedMerge commitmode)
if merged
then do
!mergecommit <- liftIO $ extractSha <$> readFile (tmpgit </> "HEAD")
!mergecommit <- liftIO $ extractSha
<$> S.readFile (tmpgit </> "HEAD")
-- This is run after the commit lock is dropped.
return $ postmerge mergecommit
else return $ return False

31
Annex/AdjustedBranch/Name.hs
View file

@ -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
Annex/Branch.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Branch (
fullname,
name,
@ -29,7 +31,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
@ -55,7 +59,7 @@ import qualified Git.LsTree
import Git.LsTree (lsTreeParams)
import qualified Git.HashObject
import Annex.HashObject
import Git.Types (Ref(..), fromRef, RefDate, TreeItemType(..))
import Git.Types (Ref(..), fromRef, fromRef', RefDate, TreeItemType(..))
import Git.FilePath
import Annex.CatFile
import Annex.Perms
@ -77,11 +81,11 @@ name = Git.Ref "git-annex"
{- Fully qualified name of the branch. -}
fullname :: Git.Ref
fullname = Git.Ref $ "refs/heads/" ++ fromRef name
fullname = Git.Ref $ "refs/heads/" <> fromRef' name
{- Branch's name in origin. -}
originname :: Git.Ref
originname = Git.Ref $ "origin/" ++ fromRef name
originname = Git.Ref $ "origin/" <> fromRef' name
{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
@ -327,9 +331,9 @@ commitIndex' jl branchref message basemessage retrynum parents = do
where
-- look for "parent ref" lines and return the refs
commitparents = map (Git.Ref . snd) . filter isparent .
map (toassoc . decodeBL) . L.split newline
map (toassoc . L.toStrict) . L.split newline
newline = fromIntegral (ord '\n')
toassoc = separate (== ' ')
toassoc = separate' (== (fromIntegral (ord ' ')))
isparent (k,_) = k == "parent"
{- The race can be detected by checking the commit's
@ -438,8 +442,8 @@ forceUpdateIndex jl branchref = do
needUpdateIndex :: Git.Ref -> Annex Bool
needUpdateIndex branchref = do
f <- fromRepo gitAnnexIndexStatus
committedref <- Git.Ref . firstLine <$>
liftIO (catchDefaultIO "" $ readFileStrict f)
committedref <- Git.Ref . firstLine' <$>
liftIO (catchDefaultIO mempty $ B.readFile f)
return (committedref /= branchref)
{- Record that the branch's index has been updated to correspond to a
@ -621,11 +625,12 @@ ignoreRefs rs = do
unlines $ map fromRef $ S.elems s
getIgnoredRefs :: Annex (S.Set Git.Sha)
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
getIgnoredRefs =
S.fromList . mapMaybe Git.Sha.extractSha . B8.lines <$> content
where
content = do
f <- fromRepo gitAnnexIgnoredRefs
liftIO $ catchDefaultIO "" $ readFile f
liftIO $ catchDefaultIO mempty $ B.readFile f
addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex ()
addMergedRefs [] = return ()
@ -643,11 +648,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,

7
Annex/ChangedRefs.hs
View file

@ -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.

3
Annex/Export.hs
View file

@ -14,7 +14,6 @@ import Types.Key
import qualified Git
import qualified Types.Remote as Remote
import Messages
import Utility.FileSystemEncoding
import Control.Applicative
import Data.Maybe
@ -34,7 +33,7 @@ exportKey sha = mk <$> catKey sha
where
mk (Just k) = AnnexKey k
mk Nothing = GitKey $ mkKey $ \k -> k
{ keyName = encodeBS $ Git.fromRef sha
{ keyName = Git.fromRef' sha
, keyVariety = SHA1Key (HasExt False)
, keySize = Nothing
, keyMtime = Nothing

4
Annex/Import.hs
View file

@ -122,7 +122,9 @@ buildImportCommit remote importtreeconfig importcommitconfig importable =
Nothing -> pure committedtree
Just dir ->
let subtreeref = Ref $
fromRef committedtree ++ ":" ++ fromRawFilePath (getTopFilePath dir)
fromRef' committedtree
<> ":"
<> getTopFilePath dir
in fromMaybe emptyTree
<$> inRepo (Git.Ref.tree subtreeref)
updateexportdb importedtree

10
Annex/TaggedPush.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.TaggedPush where
import Annex.Common
@ -16,6 +18,8 @@ import qualified Git.Command
import qualified Git.Branch
import Utility.Base64
import qualified Data.ByteString as S
{- Converts a git branch into a branch that is tagged with a UUID, typically
- the UUID of the repo that will be pushing it, and possibly with other
- information.
@ -31,11 +35,11 @@ import Utility.Base64
- refs, per git-check-ref-format.
-}
toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Ref
toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
toTaggedBranch u info b = Git.Ref $ S.intercalate "/" $ catMaybes
[ Just "refs/synced"
, Just $ fromUUID u
, toB64 <$> info
, Just $ Git.fromRef $ Git.Ref.base b
, toB64' . encodeBS <$> info
, Just $ Git.fromRef' $ Git.Ref.base b
]
fromTaggedBranch :: Git.Ref -> Maybe (UUID, Maybe String)

2
Assistant/Threads/Merger.hs
View file

@ -109,6 +109,6 @@ isAnnexBranch f = n `isSuffixOf` f
n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref
fileToBranch f = Git.Ref $ "refs" </> base
fileToBranch f = Git.Ref $ encodeBS' $ "refs" </> base
where
base = Prelude.last $ split "/refs/" f

2
Assistant/Threads/Watcher.hs
View file

@ -330,7 +330,7 @@ addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
debug ["add symlink", file]
liftAnnex $ do
v <- catObjectDetails $ Ref $ ':':file
v <- catObjectDetails $ Ref $ encodeBS' $ ':':file
case v of
Just (currlink, sha, _type)
| s2w8 link == L.unpack currlink ->

3
Command/Export.hs
View file

@ -37,6 +37,7 @@ import Utility.Tmp
import Utility.Metered
import Utility.Matcher
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Control.Concurrent
@ -112,7 +113,7 @@ getExportCommit r treeish
return (fmap (tb, ) commitsha)
| otherwise = return Nothing
where
baseref = Ref $ takeWhile (/= ':') $ fromRef $
baseref = Ref $ S8.takeWhile (/= ':') $ fromRef' $
Git.Ref.removeBase refsheads treeish
refsheads = "refs/heads"

2
Command/FindRef.hs
View file

@ -22,6 +22,6 @@ seek o = Find.seek o'
where
o' = o
{ Find.keyOptions = Just $ WantBranchKeys $
map Git.Ref (Find.findThese o)
map (Git.Ref . encodeBS') (Find.findThese o)
, Find.findThese = []
}

2
Command/Import.hs
View file

@ -66,7 +66,7 @@ optParser desc = do
[bs] ->
let (branch, subdir) = separate (== ':') bs
in RemoteImportOptions r
(Ref branch)
(Ref (encodeBS' branch))
(if null subdir then Nothing else Just subdir)
_ -> giveup "expected BRANCH[:SUBDIR]"

2
Command/Info.hs
View file

@ -181,7 +181,7 @@ dirInfo o dir = showCustom (unwords ["info", dir]) $ do
treeishInfo :: InfoOptions -> String -> Annex ()
treeishInfo o t = do
mi <- getTreeStatInfo o (Git.Ref t)
mi <- getTreeStatInfo o (Git.Ref (encodeBS' t))
case mi of
Nothing -> noInfo t
Just i -> showCustom (unwords ["info", t]) $ do

3
Command/Log.hs
View file

@ -264,7 +264,8 @@ parseGitRawLog config = parse epoch
parseRawChangeLine :: String -> Maybe (Git.Ref, Git.Ref)
parseRawChangeLine = go . words
where
go (_:_:oldsha:newsha:_) = Just (Git.Ref oldsha, Git.Ref newsha)
go (_:_:oldsha:newsha:_) =
Just (Git.Ref (encodeBS oldsha), Git.Ref (encodeBS newsha))
go _ = Nothing
parseTimeStamp :: String -> POSIXTime

2
Command/Merge.hs
View file

@ -26,7 +26,7 @@ seek [] = do
commandAction mergeSyncedBranch
seek bs = do
prepMerge
forM_ bs (commandAction . mergeBranch . Git.Ref)
forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS')
mergeAnnexBranch :: CommandStart
mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do

4
Command/ResolveMerge.hs
View file

@ -13,6 +13,8 @@ import Git.Sha
import qualified Git.Branch
import Annex.AutoMerge
import qualified Data.ByteString as S
cmd :: Command
cmd = command "resolvemerge" SectionPlumbing
"resolve merge conflicts"
@ -27,7 +29,7 @@ start = starting "resolvemerge" (ActionItemOther Nothing) $ do
d <- fromRawFilePath <$> fromRepo Git.localGitDir
let merge_head = d </> "MERGE_HEAD"
them <- fromMaybe (error nomergehead) . extractSha
<$> liftIO (readFile merge_head)
<$> liftIO (S.readFile merge_head)
ifM (resolveMerge (Just us) them False)
( do
void $ commitResolvedMerge Git.Branch.ManualCommit

8
Command/Sync.hs
View file

@ -72,6 +72,8 @@ import Utility.Process.Transcript
import Control.Concurrent.MVar
import qualified Data.Map as M
import qualified Data.ByteString as S
import Data.Char
cmd :: Command
cmd = withGlobalOptions [jobsOption] $
@ -444,11 +446,11 @@ importRemote o mergeconfig remote currbranch
| otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of
Nothing -> noop
Just tb -> do
let (b, s) = separate (== ':') (Git.fromRef tb)
let (b, p) = separate' (== (fromIntegral (ord ':'))) (Git.fromRef' tb)
let branch = Git.Ref b
let subdir = if null s
let subdir = if S.null p
then Nothing
else Just (asTopFilePath (toRawFilePath s))
else Just (asTopFilePath p)
Command.Import.seekRemote remote branch subdir
void $ mergeRemote remote currbranch mergeconfig o
where

2
Command/Uninit.hs
View file

@ -35,7 +35,7 @@ check = do
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
giveup "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . Prelude.head . lines . decodeBS' <$> revhead
current_branch = Git.Ref . encodeBS' . Prelude.head . lines . decodeBS' <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]

22
Command/Unused.hs
View file

@ -5,12 +5,10 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Command.Unused where
import qualified Data.Map as M
import Command
import Logs.Unused
import Annex.Content
@ -37,6 +35,11 @@ import Annex.BloomFilter
import qualified Database.Keys
import Annex.InodeSentinal
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Char
cmd :: Command
cmd = command "unused" SectionMaintenance "look for unused file content"
paramNothing (seek <$$> optParser)
@ -221,8 +224,7 @@ withKeysReferenced' mdir initial a = do
withKeysReferencedDiffGitRefs :: RefSpec -> (Key -> Annex ()) -> Annex ()
withKeysReferencedDiffGitRefs refspec a = do
rs <- relevantrefs . decodeBS'
<$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"])
rs <- relevantrefs <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"])
shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha)
=<< inRepo Git.Branch.currentUnsafe
let haveHead = any (\(shaRef, _) -> Just shaRef == shaHead) rs
@ -233,12 +235,12 @@ withKeysReferencedDiffGitRefs refspec a = do
where
relevantrefs = map (\(r, h) -> (Git.Ref r, Git.Ref h)) .
filter ourbranches .
map (separate (== ' ')) .
lines
map (separate' (== (fromIntegral (ord ' ')))) .
S8.lines
nubRefs = nubBy (\(x, _) (y, _) -> x == y)
ourbranchend = '/' : Git.fromRef Annex.Branch.name
ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
&& not ("refs/synced/" `isPrefixOf` b)
ourbranchend = S.cons (fromIntegral (ord '/')) (Git.fromRef' Annex.Branch.name)
ourbranches (_, b) = not (ourbranchend `S.isSuffixOf` b)
&& not ("refs/synced/" `S.isPrefixOf` b)
&& not (is_branchView (Git.Ref b))
getreflog rs = inRepo $ Git.RefLog.getMulti rs

15
Database/Keys.hs
View file

@ -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,11 +280,12 @@ reconcileStaged qh = do
, Param "--no-ext-diff"
]
procdiff (info:file:rest) changed = case words info of
((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])
procdiff (info:file:rest) changed
| ":" `S.isPrefixOf` info = case S8.words info of
(_colonsrcmode:dstmode:_srcsha:dstsha:_change:[])
-- Only want files, not symlinks
| dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do
maybe noop (reconcile (asTopFilePath (toRawFilePath file)))
| dstmode /= fmtTreeItemType TreeSymlink -> do
maybe noop (reconcile (asTopFilePath file))
=<< catKey (Ref dstsha)
procdiff rest True
| otherwise -> procdiff rest changed

5
Database/Types.hs
View file

@ -28,6 +28,7 @@ import Foreign.C.Types
import Key
import Utility.InodeCache
import Utility.FileSize
import Utility.FileSystemEncoding
import Git.Types
import Types.UUID
import Types.Import
@ -94,10 +95,10 @@ newtype SSha = SSha String
deriving (Eq, Show)
toSSha :: Sha -> SSha
toSSha (Ref s) = SSha s
toSSha (Ref s) = SSha (decodeBS' s)
fromSSha :: SSha -> Ref
fromSSha (SSha s) = Ref s
fromSSha (SSha s) = Ref (encodeBS' s)
instance PersistField SSha where
toPersistValue (SSha b) = toPersistValue b

1
Git.hs
View file

@ -14,6 +14,7 @@ module Git (
Repo(..),
Ref(..),
fromRef,
fromRef',
Branch,
Sha,
Tag,

22
Git/Branch.hs
View file

@ -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

39
Git/CatFile.hs
View file

@ -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 ' ')

9
Git/Command.hs
View file

@ -81,11 +81,16 @@ pipeReadStrict' reader params repo = assertLocal repo $
{- Runs a git command, feeding it an input, and returning its output,
- which is expected to be fairly small, since it's all read into memory
- strictly. -}
pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String
pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString
pipeWriteRead params writer repo = assertLocal repo $
writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo)
(gitEnv repo) writer (Just adjusthandle)
(gitEnv repo) writer'
where
writer' = case writer of
Nothing -> Nothing
Just a -> Just $ \h -> do
adjusthandle h
a h
adjusthandle h = hSetNewlineMode h noNewlineTranslation
{- Runs a git command, feeding it input on a handle with an action. -}

2
Git/Credential.hs
View file

@ -58,7 +58,7 @@ urlCredential = Credential . M.singleton "url"
runCredential :: String -> Credential -> Repo -> IO Credential
runCredential action input r =
parseCredential <$> pipeWriteRead
parseCredential . decodeBS <$> pipeWriteRead
[ Param "credential"
, Param action
]

47
Git/DiffTree.hs
View file

@ -1,6 +1,6 @@
{- git diff-tree interface
-
- Copyright 2012 Joey Hess <id@joeyh.name>
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -17,7 +17,9 @@ module Git.DiffTree (
commitDiff,
) where
import Numeric
import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
import Common
import Git
@ -27,6 +29,7 @@ import Git.FilePath
import Git.DiffTreeItem
import qualified Git.Filename
import qualified Git.Ref
import Utility.Attoparsec
{- Checks if the DiffTreeItem modifies a file with a given name
- or under a directory by that name. -}
@ -89,7 +92,7 @@ commitDiff ref = getdiff (Param "show")
getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
getdiff command params repo = do
(diff, cleanup) <- pipeNullSplit ps repo
return (parseDiffRaw (map decodeBL diff), cleanup)
return (parseDiffRaw diff, cleanup)
where
ps =
command :
@ -100,26 +103,28 @@ getdiff command params repo = do
params
{- Parses --raw output used by diff-tree and git-log. -}
parseDiffRaw :: [String] -> [DiffTreeItem]
parseDiffRaw :: [L.ByteString] -> [DiffTreeItem]
parseDiffRaw l = go l
where
go [] = []
go (info:f:rest) = mk info f : go rest
go (s:[]) = error $ "diff-tree parse error near \"" ++ s ++ "\""
go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of
A.Done _ r -> r : go rest
A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err
go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\""
mk info f = DiffTreeItem
{ srcmode = readmode srcm
, dstmode = readmode dstm
, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
, status = s
, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f
}
-- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
parserDiffRaw :: RawFilePath -> A.Parser DiffTreeItem
parserDiffRaw f = DiffTreeItem
<$ A8.char ':'
<*> octal
<* A8.char ' '
<*> octal
<* A8.char ' '
<*> (maybe (fail "bad srcsha") return . extractSha =<< nextword)
<* A8.char ' '
<*> (maybe (fail "bad dstsha") return . extractSha =<< nextword)
<* A8.char ' '
<*> A.takeByteString
<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f)
where
readmode = fst . Prelude.head . readOct
-- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
(srcm, past_srcm) = splitAt 7 $ drop 1 info
(dstm, past_dstm) = splitAt 7 past_srcm
(ssha, past_ssha) = separate (== ' ') past_dstm
(dsha, s) = separate (== ' ') past_ssha
nextword = A8.takeTill (== ' ')

3
Git/DiffTreeItem.hs
View file

@ -10,6 +10,7 @@ module Git.DiffTreeItem (
) where
import System.Posix.Types
import qualified Data.ByteString as S
import Git.FilePath
import Git.Types
@ -19,6 +20,6 @@ data DiffTreeItem = DiffTreeItem
, dstmode :: FileMode
, srcsha :: Sha -- null sha if file was added
, dstsha :: Sha -- null sha if file was deleted
, status :: String
, status :: S.ByteString
, file :: TopFilePath
} deriving Show

2
Git/FilePath.hs
View file

@ -50,7 +50,7 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
{- Git uses the branch:file form to refer to a BranchFilePath -}
descBranchFilePath :: BranchFilePath -> S.ByteString
descBranchFilePath (BranchFilePath b f) =
encodeBS' (fromRef b) <> ":" <> getTopFilePath f
fromRef' b <> ":" <> getTopFilePath f
{- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath

3
Git/Fsck.hs
View file

@ -139,7 +139,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
] r
findShas :: [String] -> [Sha]
findShas = catMaybes . map extractSha . concat . map words . filter wanted
findShas = catMaybes . map (extractSha . encodeBS')
. concat . map words . filter wanted
where
wanted l = not ("dangling " `isPrefixOf` l)

3
Git/HashObject.hs
View file

@ -18,6 +18,7 @@ import qualified Utility.CoProcess as CoProcess
import Utility.Tmp
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
@ -39,7 +40,7 @@ hashFile :: HashObjectHandle -> FilePath -> IO Sha
hashFile h file = CoProcess.query h send receive
where
send to = hPutStrLn to =<< absPath file
receive from = getSha "hash-object" $ hGetLine from
receive from = getSha "hash-object" $ S8.hGetLine from
class HashableBlob t where
hashableBlobToHandle :: Handle -> t -> IO ()

10
Git/History.hs
View file

@ -15,6 +15,9 @@ import Git.Command
import Git.Sha
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
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)
@ -53,8 +56,9 @@ getHistoryToDepth n commit r = do
!h <- fmap (truncateHistoryToDepth n)
. build Nothing
. map parsehistorycommit
. lines
<$> hGetContents inh
. map L.toStrict
. L8.lines
<$> L.hGetContents inh
hClose inh
void $ waitForProcess pid
return h
@ -93,7 +97,7 @@ getHistoryToDepth n commit r = do
, Param "--format=%T %H %P"
]
parsehistorycommit l = case map extractSha (splitc ' ' l) of
parsehistorycommit l = case map extractSha (B8.split ' ' l) of
(Just t:Just c:ps) -> Just $
( HistoryCommit
{ historyCommit = c

23
Git/LsFiles.hs
View file

@ -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. -}
@ -284,7 +285,7 @@ parseUnmerged s
then Nothing
else do
treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha rawsha
sha <- extractSha (encodeBS' rawsha)
return $ InternalUnmerged (stage == 2) (toRawFilePath file)
(Just treeitemtype) (Just sha)
_ -> Nothing

2
Git/LsTree.hs
View file

@ -96,7 +96,7 @@ parserLsTree = TreeItem
<*> A8.takeTill (== ' ')
<* A8.char ' '
-- sha
<*> (Ref . decodeBS' <$> A8.takeTill (== '\t'))
<*> (Ref <$> A8.takeTill (== '\t'))
<* A8.char '\t'
-- file
<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)

2
Git/Objects.hs
View file

@ -26,7 +26,7 @@ listPackFiles r = filter (".pack" `isSuffixOf`)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories)
<$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r)
looseObjectFile :: Repo -> Sha -> FilePath

54
Git/Ref.hs
View file

@ -17,6 +17,7 @@ import Git.Types
import Data.Char (chr, ord)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
headRef :: Ref
headRef = Ref "HEAD"
@ -25,7 +26,7 @@ headFile :: Repo -> FilePath
headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
setHeadRef :: Ref -> Repo -> IO ()
setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)
setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref)
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
@ -41,10 +42,11 @@ base = removeBase "refs/heads/" . removeBase "refs/remotes/"
{- Removes a directory such as "refs/heads/master" from a
- fully qualified ref. Any ref not starting with it is left as-is. -}
removeBase :: String -> Ref -> Ref
removeBase dir (Ref r)
| prefix `isPrefixOf` r = Ref (drop (length prefix) r)
| otherwise = Ref r
removeBase dir r
| prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs
| otherwise = r
where
rs = fromRef r
prefix = case end dir of
['/'] -> dir
_ -> dir ++ "/"
@ -53,7 +55,7 @@ removeBase dir (Ref r)
- refs/heads/master, yields a version of that ref under the directory,
- such as refs/remotes/origin/master. -}
underBase :: String -> Ref -> Ref
underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r)
{- Convert a branch such as "master" into a fully qualified ref. -}
branchRef :: Branch -> Ref
@ -66,21 +68,25 @@ branchRef = underBase "refs/heads"
- of a repo.
-}
fileRef :: RawFilePath -> Ref
fileRef f = Ref $ ":./" ++ fromRawFilePath f
fileRef f = Ref $ ":./" <> f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d
{- A Ref that can be used to refer to a file in the repository as it
- appears in a given Ref. -}
fileFromRef :: Ref -> RawFilePath -> Ref
fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr)
{- Checks if a ref exists. -}
exists :: Ref -> Repo -> IO Bool
exists ref = runBool
[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
[ Param "show-ref"
, Param "--verify"
, Param "-q"
, Param $ fromRef ref
]
{- The file used to record a ref. (Git also stores some refs in a
- packed-refs file.) -}
@ -107,26 +113,26 @@ sha branch repo = process <$> showref repo
]
process s
| S.null s = Nothing
| otherwise = Just $ Ref $ decodeBS' $ firstLine' s
| otherwise = Just $ Ref $ firstLine' s
headSha :: Repo -> IO (Maybe Sha)
headSha = sha headRef
{- List of (shas, branches) matching a given ref or refs. -}
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
matching refs repo = matching' (map fromRef refs) repo
matching = matching' []
{- Includes HEAD in the output, if asked for it. -}
matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
matchingWithHEAD = matching' [Param "--head"]
{- List of (shas, branches) matching a given ref spec. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
matching' ps repo = map gen . lines . decodeBS' <$>
pipeReadStrict (Param "show-ref" : map Param ps) repo
matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)]
matching' ps rs repo = map gen . S8.lines <$>
pipeReadStrict (Param "show-ref" : ps ++ rps) repo
where
gen l = let (r, b) = separate (== ' ') l
gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l
in (Ref r, Ref b)
rps = map (Param . fromRef) rs
{- List of (shas, branches) matching a given ref.
- Duplicate shas are filtered out. -}
@ -137,7 +143,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
{- List of all refs. -}
list :: Repo -> IO [(Sha, Ref)]
list = matching' []
list = matching' [] []
{- Deletes a ref. This can delete refs that are not branches,
- which git branch --delete refuses to delete. -}
@ -154,13 +160,17 @@ delete oldvalue ref = run
- The ref may be something like a branch name, and it could contain
- ":subdir" if a subtree is wanted. -}
tree :: Ref -> Repo -> IO (Maybe Sha)
tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict
[ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]
tree (Ref ref) = extractSha <$$> pipeReadStrict
[ Param "rev-parse"
, Param "--verify"
, Param "--quiet"
, Param (decodeBS' ref')
]
where
ref' = if ":" `isInfixOf` ref
ref' = if ":" `S.isInfixOf` ref
then ref
-- de-reference commit objects to the tree
else ref ++ ":"
else ref <> ":"
{- Checks if a String is a legal git ref name.
-

5
Git/RefLog.hs
View file

@ -12,6 +12,9 @@ import Git
import Git.Command
import Git.Sha
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
{- Gets the reflog for a given branch. -}
get :: Branch -> Repo -> IO [Sha]
get b = getMulti [b]
@ -21,7 +24,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha]
getMulti bs = get' (map (Param . fromRef) bs)
get' :: [CommandParam] -> Repo -> IO [Sha]
get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'
get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps'
where
ps' = catMaybes
[ Just $ Param "log"

17
Git/Repair.hs
View file

@ -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])

32
Git/Sha.hs
View file

@ -5,31 +5,43 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Git.Sha where
import Common
import Git.Types
import qualified Data.ByteString as S
import Data.Char
{- Runs an action that causes a git subcommand to emit a Sha, and strips
- any trailing newline, returning the sha. -}
getSha :: String -> IO String -> IO Sha
getSha :: String -> IO S.ByteString -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
where
bad = error $ "failed to read sha from git " ++ subcommand
{- Extracts the Sha from a string. There can be a trailing newline after
- it, but nothing else. -}
extractSha :: String -> Maybe Sha
{- Extracts the Sha from a ByteString.
-
- There can be a trailing newline after it, but nothing else.
-}
extractSha :: S.ByteString -> Maybe Sha
extractSha s
| len `elem` shaSizes = val s
| len - 1 `elem` shaSizes && length s' == len - 1 = val s'
| len - 1 `elem` shaSizes && S.length s' == len - 1 = val s'
| otherwise = Nothing
where
len = length s
s' = firstLine s
len = S.length s
s' = firstLine' s
val v
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
| S.all validinsha v = Just $ Ref v
| otherwise = Nothing
validinsha w = or
[ w >= 48 && w <= 57 -- 0-9
, w >= 97 && w <= 102 -- a-f
, w >= 65 && w <= 70 -- A-F
]
{- Sizes of git shas. -}
shaSizes :: [Int]
@ -41,7 +53,9 @@ shaSizes =
{- Git plumbing often uses a all 0 sha to represent things like a
- deleted file. -}
nullShas :: [Sha]
nullShas = map (\n -> Ref (replicate n '0')) shaSizes
nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes
where
zero = fromIntegral (ord '0')
{- Sha to provide to git plumbing when deleting a file.
-

3
Git/Tree.hs
View file

@ -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

7
Git/Types.hs
View file

@ -81,11 +81,14 @@ instance IsString ConfigValue where
type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
newtype Ref = Ref String
newtype Ref = Ref S.ByteString
deriving (Eq, Ord, Read, Show)
fromRef :: Ref -> String
fromRef (Ref s) = s
fromRef = decodeBS' . fromRef'
fromRef' :: Ref -> S.ByteString
fromRef' (Ref s) = s
{- Aliases for Ref. -}
type Branch = Ref

18
Git/UnionMerge.hs
View file

@ -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.

8
Git/UpdateIndex.hs
View file

@ -75,14 +75,14 @@ lsTree (Ref x) repo streamer = do
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
@ -90,7 +90,7 @@ updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
updateIndexLine sha treeitemtype file = L.fromStrict $
fmtTreeItemType treeitemtype
<> " blob "
<> encodeBS (fromRef sha)
<> fromRef' sha
<> "\t"
<> indexPath file
@ -108,7 +108,7 @@ unstageFile file repo = do
unstageFile' :: TopFilePath -> Streamer
unstageFile' p = pureStreamer $ L.fromStrict $
"0 "
<> encodeBS' (fromRef deleteSha)
<> fromRef' deleteSha
<> "\t"
<> indexPath p

4
Logs/Export.hs
View file

@ -158,12 +158,12 @@ buildExported exported = go (exportedTreeish exported : incompleteExportedTreeis
where
go [] = mempty
go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ]
rref r = byteString (encodeBS' (Git.fromRef r))
rref = byteString . Git.fromRef'
exportedParser :: A.Parser Exported
exportedParser = Exported <$> refparser <*> many refparser
where
refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') )
refparser = (Git.Ref <$> A8.takeWhile1 (/= ' ') )
<* ((const () <$> A8.char ' ') <|> A.endOfInput)
logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a

2
Logs/FsckResults.hs
View file

@ -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
View file

@ -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

2
Test.hs
View file

@ -1664,7 +1664,7 @@ test_add_subdirs = intmpclonerepo $ do
unlessM (hasUnlockedFiles <$> getTestMode) $ do
git_annex "sync" [] @? "sync failed"
l <- annexeval $ Utility.FileSystemEncoding.decodeBL
<$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo")
<$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo"))
"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)
createDirectory "dir2"

2
Types/GitConfig.hs
View file

@ -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
)

2
Types/RefSpec.hs
View file

@ -32,7 +32,7 @@ parseRefSpec v = case partitionEithers (map mk $ splitc ':' v) of
mk ('+':s)
| any (`elem` s) "*?" =
Right $ AddMatching $ compileGlob s CaseSensative
| otherwise = Right $ AddRef $ Ref s
| otherwise = Right $ AddRef $ Ref $ encodeBS s
mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative
mk "reflog" = Right AddRefLog
mk s = Left $ "bad refspec item \"" ++ s ++ "\" (expected + or - prefix)"

2
Types/View.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Types.View where
import Annex.Common

3
Upgrade/V2.hs
View file

@ -92,7 +92,8 @@ logFiles dir = return . filter (".log" `isSuffixOf`)
push :: Annex ()
push = do
origin_master <- inRepo $ Git.Ref.exists $ Git.Ref "origin/master"
origin_master <- inRepo $ Git.Ref.exists $
Git.Ref $ encodeBS' "origin/master"
origin_gitannex <- Annex.Branch.hasOrigin
case (origin_master, origin_gitannex) of
(_, True) -> do

2
Upgrade/V5/Direct.hs
View file

@ -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 ()

8
Utility/Misc.hs
View file

@ -11,6 +11,7 @@ module Utility.Misc (
hGetContentsStrict,
readFileStrict,
separate,
separate',
firstLine,
firstLine',
segment,
@ -54,6 +55,13 @@ separate c l = unbreak $ break c l
| null b = r
| otherwise = (a, tail b)
separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)
separate' c l = unbreak $ S.break c l
where
unbreak r@(a, b)
| S.null b = r
| otherwise = (a, S.tail b)
{- Breaks out the first line. -}
firstLine :: String -> String
firstLine = takeWhile (/= '\n')

16
Utility/Process.hs
View file

@ -1,7 +1,7 @@
{- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@ -53,6 +53,7 @@ import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
import qualified Data.ByteString as S
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
@ -85,25 +86,20 @@ writeReadProcessEnv
-> [String]
-> Maybe [(String, String)]
-> (Maybe (Handle -> IO ()))
-> (Maybe (Handle -> IO ()))
-> IO String
writeReadProcessEnv cmd args environ writestdin adjusthandle = do
-> IO S.ByteString
writeReadProcessEnv cmd args environ writestdin = do
(Just inh, Just outh, _, pid) <- createProcess p
maybe (return ()) (\a -> a inh) adjusthandle
maybe (return ()) (\a -> a outh) adjusthandle
-- fork off a thread to start consuming the output
output <- hGetContents outh
outMVar <- newEmptyMVar
_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
_ <- forkIO $ putMVar outMVar =<< S.hGetContents outh
-- now write and flush any input
maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
hClose inh -- done with stdin
-- wait on the output
takeMVar outMVar
output <- takeMVar outMVar
hClose outh
-- wait on the process

6
doc/todo/optimise_by_converting_Ref_to_ByteString.mdwn
View file

@ -3,3 +3,9 @@ to contain a ByteString, rather than a String, would eliminate a
fromRawFilePath that uses about 1% of runtime.
[[!tag confirmed]]
> Well, I did the conversion. Running that command does not seem to have
> sped up by any appreciable amount. But, I did notice several places where
> using ByteString is certainly more efficient. It may just be that it
> doesn't matter if git-annex is IO bound etc. Still, glad I did it.
> [[done]] --[[Joey]]