4bf7940d6b
Fix behavior of several commands, including reinject, addurl, and rmurl when given an absolute path to an unlocked file, or a relative path that leaves and re-enters the repository. To avoid slowing down all the cases where the paths are already ok with an unncessary call to getCurrentDirectory, put in an optimisation in relPathCwdToFile. That will probably also speed up other parts of git-annex by some small amount, but I have not benchmarked. Note that I did not convert branchFileRef, because it seems likely that it will be used with a file that is not provided by the user, so is already in a sane format. This is certainly true for the way git-annex uses it, though maybe arguable to the extent Git.Ref is a reusable library.
213 lines
6.2 KiB
Haskell
213 lines
6.2 KiB
Haskell
{- git ref stuff
|
|
-
|
|
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Git.Ref where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import Git.Sha
|
|
import Git.Types
|
|
import Git.FilePath
|
|
|
|
import Data.Char (chr, ord)
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Char8 as S8
|
|
|
|
headRef :: Ref
|
|
headRef = Ref "HEAD"
|
|
|
|
headFile :: Repo -> FilePath
|
|
headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
|
|
|
|
setHeadRef :: Ref -> Repo -> IO ()
|
|
setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref)
|
|
|
|
{- Converts a fully qualified git ref into a user-visible string. -}
|
|
describe :: Ref -> String
|
|
describe = fromRef . base
|
|
|
|
{- Often git refs are fully qualified
|
|
- (eg refs/heads/master or refs/remotes/origin/master).
|
|
- Converts such a fully qualified ref into a base ref
|
|
- (eg: master or origin/master). -}
|
|
base :: Ref -> Ref
|
|
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 r
|
|
| prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs
|
|
| otherwise = r
|
|
where
|
|
rs = fromRef r
|
|
prefix = case end dir of
|
|
['/'] -> dir
|
|
_ -> dir ++ "/"
|
|
|
|
{- Given a directory such as "refs/remotes/origin", and a ref such as
|
|
- 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 $ encodeBS dir <> "/" <> fromRef' (base r)
|
|
|
|
{- Convert a branch such as "master" into a fully qualified ref. -}
|
|
branchRef :: Branch -> Ref
|
|
branchRef = underBase "refs/heads"
|
|
|
|
{- A Ref that can be used to refer to a file in the repository, as staged
|
|
- in the index.
|
|
-}
|
|
fileRef :: RawFilePath -> IO Ref
|
|
fileRef f = do
|
|
-- The filename could be absolute, or contain eg "../repo/file",
|
|
-- neither of which work in a ref, so convert it to a minimal
|
|
-- relative path.
|
|
f' <- relPathCwdToFile f
|
|
-- Prefixing the file with ./ makes this work even when in a
|
|
-- subdirectory of a repo. Eg, ./foo in directory bar refers
|
|
-- to bar/foo, not to foo in the top of the repository.
|
|
return $ Ref $ ":./" <> toInternalGitPath f'
|
|
|
|
{- A Ref that can be used to refer to a file in a particular branch. -}
|
|
branchFileRef :: Branch -> RawFilePath -> Ref
|
|
branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f
|
|
|
|
{- Converts a Ref to refer to the content of the Ref on a given date. -}
|
|
dateRef :: Ref -> RefDate -> Ref
|
|
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 -> IO Ref
|
|
fileFromRef r f = do
|
|
(Ref fr) <- fileRef f
|
|
return (Ref (fromRef' r <> fr))
|
|
|
|
{- Checks if a ref exists. Note that it must be fully qualified,
|
|
- eg refs/heads/master rather than master. -}
|
|
exists :: Ref -> Repo -> IO Bool
|
|
exists ref = runBool
|
|
[ 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.) -}
|
|
file :: Ref -> Repo -> FilePath
|
|
file ref repo = fromRawFilePath (localGitDir repo) </> fromRef ref
|
|
|
|
{- Checks if HEAD exists. It generally will, except for in a repository
|
|
- that was just created. -}
|
|
headExists :: Repo -> IO Bool
|
|
headExists repo = do
|
|
ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo
|
|
return $ any (" HEAD" `S.isSuffixOf`) ls
|
|
where
|
|
nl = fromIntegral (ord '\n')
|
|
|
|
{- Get the sha of a fully qualified git ref, if it exists. -}
|
|
sha :: Branch -> Repo -> IO (Maybe Sha)
|
|
sha branch repo = process <$> showref repo
|
|
where
|
|
showref = pipeReadStrict
|
|
[ Param "show-ref"
|
|
, Param "--hash" -- get the hash
|
|
, Param $ fromRef branch
|
|
]
|
|
process s
|
|
| S.null s = Nothing
|
|
| 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 = matching' []
|
|
|
|
{- Includes HEAD in the output, if asked for it. -}
|
|
matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
|
|
matchingWithHEAD = matching' [Param "--head"]
|
|
|
|
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' (== 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. -}
|
|
matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)]
|
|
matchingUniq refs repo = nubBy uniqref <$> matching refs repo
|
|
where
|
|
uniqref (a, _) (b, _) = a == b
|
|
|
|
{- List of all refs. -}
|
|
list :: Repo -> IO [(Sha, Ref)]
|
|
list = matching' [] []
|
|
|
|
{- Deletes a ref. This can delete refs that are not branches,
|
|
- which git branch --delete refuses to delete. -}
|
|
delete :: Sha -> Ref -> Repo -> IO ()
|
|
delete oldvalue ref = run
|
|
[ Param "update-ref"
|
|
, Param "-d"
|
|
, Param $ fromRef ref
|
|
, Param $ fromRef oldvalue
|
|
]
|
|
|
|
{- Gets the sha of the tree a ref uses.
|
|
-
|
|
- 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 <$$> pipeReadStrict
|
|
[ Param "rev-parse"
|
|
, Param "--verify"
|
|
, Param "--quiet"
|
|
, Param (decodeBS' ref')
|
|
]
|
|
where
|
|
ref' = if ":" `S.isInfixOf` ref
|
|
then ref
|
|
-- de-reference commit objects to the tree
|
|
else ref <> ":"
|
|
|
|
{- Checks if a String is a legal git ref name.
|
|
-
|
|
- The rules for this are complex; see git-check-ref-format(1) -}
|
|
legal :: Bool -> String -> Bool
|
|
legal allowonelevel s = all (== False) illegal
|
|
where
|
|
illegal =
|
|
[ any ("." `isPrefixOf`) pathbits
|
|
, any (".lock" `isSuffixOf`) pathbits
|
|
, not allowonelevel && length pathbits < 2
|
|
, contains ".."
|
|
, any (\c -> contains [c]) illegalchars
|
|
, begins "/"
|
|
, ends "/"
|
|
, contains "//"
|
|
, ends "."
|
|
, contains "@{"
|
|
, null s
|
|
]
|
|
contains v = v `isInfixOf` s
|
|
ends v = v `isSuffixOf` s
|
|
begins v = v `isPrefixOf` s
|
|
|
|
pathbits = splitc '/' s
|
|
illegalchars = " ~^:?*[\\" ++ controlchars
|
|
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
|