merging sqlite and bs branches

Since the sqlite branch uses blobs extensively, there are some
performance benefits, ByteStrings now get stored and retrieved w/o
conversion in some cases like in Database.Export.
This commit is contained in:
Joey Hess 2019-12-06 15:17:54 -04:00
commit 2f9a80d803
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
266 changed files with 2860 additions and 1325 deletions

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Git.AutoCorrect where
import Common
@ -44,7 +46,7 @@ fuzzymatches input showchoice choices = fst $ unzip $
-}
prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()
prepare input showmatch matches r =
case readish . Git.Config.get "help.autocorrect" "0" =<< r of
case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of
Just n
| n == 0 -> list
| n < 0 -> warn Nothing

View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.Branch where
@ -16,6 +17,8 @@ import Git.Command
import qualified Git.Config
import qualified Git.Ref
import qualified Data.ByteString as B
{- The currently checked out branch.
-
- In a just initialized git repo before the first commit,
@ -29,19 +32,19 @@ current r = do
case v of
Nothing -> return Nothing
Just branch ->
ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
( return Nothing
, return v
)
{- The current branch, which may not really exist yet. -}
currentUnsafe :: Repo -> IO (Maybe Branch)
currentUnsafe r = parse . firstLine
currentUnsafe r = parse . firstLine'
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where
parse l
| null l = Nothing
| otherwise = Just $ Git.Ref l
parse b
| B.null b = Nothing
| otherwise = Just $ Git.Ref $ decodeBS b
{- Checks if the second branch has any commits not present on the first
- branch. -}
@ -53,7 +56,8 @@ changed origbranch newbranch repo
where
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
changed' origbranch newbranch extraps repo =
decodeBS <$> pipeReadStrict ps repo
where
ps =
[ Param "log"
@ -72,7 +76,7 @@ changedCommits origbranch newbranch extraps repo =
-
- This requires there to be a path from the old to the new. -}
fastForwardable :: Ref -> Ref -> Repo -> IO Bool
fastForwardable old new repo = not . null <$>
fastForwardable old new repo = not . B.null <$>
pipeReadStrict
[ Param "log"
, Param $ fromRef old ++ ".." ++ fromRef new
@ -132,8 +136,8 @@ applyCommitMode commitmode ps
applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]
applyCommitModeForCommitTree commitmode ps r
| commitmode == ManualCommit =
case (Git.Config.getMaybe "commit.gpgsign" r) of
Just s | Git.Config.isTrue s == Just True ->
case Git.Config.getMaybe "commit.gpgsign" r of
Just s | Git.Config.isTrue' s == Just True ->
Param "-S":ps
_ -> ps'
| otherwise = ps'
@ -160,7 +164,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" $
pipeReadStrict [Param "write-tree"] repo
decodeBS' <$> pipeReadStrict [Param "write-tree"] repo
ifM (cancommit tree)
( do
sha <- commitTree commitmode message parentrefs tree repo

View file

@ -66,13 +66,13 @@ catFileStop h = do
CoProcess.stop (checkFileProcess h)
{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
catFile h branch file = catObject h $ Ref $
fromRef branch ++ ":" ++ toInternalGitPath file
fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails h branch file = catObjectDetails h $ Ref $
fromRef branch ++ ":" ++ toInternalGitPath file
fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
@ -148,7 +148,7 @@ parseResp object l
| otherwise = case words l of
[sha, objtype, size]
| length sha == shaSize ->
case (readObjectType objtype, reads size) of
case (readObjectType (encodeBS objtype), reads size) of
(Just t, [(bytes, "")]) ->
Just $ ParsedResp (Ref sha) bytes t
_ -> Nothing
@ -185,7 +185,7 @@ querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))
<$> querySingle (Param "-s") r repo hGetContentsStrict
queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType)
queryObjectType r repo = maybe Nothing (readObjectType . takeWhile (/= '\n'))
queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n'))
<$> querySingle (Param "-t") r repo hGetContentsStrict
queryContent :: Ref -> Repo -> IO (Maybe L.ByteString)

View file

@ -14,6 +14,9 @@ import Git
import Git.Types
import qualified Utility.CoProcess as CoProcess
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
@ -50,10 +53,10 @@ runQuiet params repo = withQuietOutput createProcessSuccess $
- read, that will wait on the command, and
- return True if it succeeded. Failure to wait will result in zombies.
-}
pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)
pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool)
pipeReadLazy params repo = assertLocal repo $ do
(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }
c <- hGetContents h
c <- L.hGetContents h
return (c, checkSuccessProcess pid)
where
p = gitCreateProcess params repo
@ -62,8 +65,8 @@ pipeReadLazy params repo = assertLocal repo $ do
-
- Nonzero exit status is ignored.
-}
pipeReadStrict :: [CommandParam] -> Repo -> IO String
pipeReadStrict = pipeReadStrict' hGetContentsStrict
pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString
pipeReadStrict = pipeReadStrict' S.hGetContents
{- The reader action must be strict. -}
pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
@ -93,23 +96,30 @@ pipeWrite params repo = assertLocal repo $
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it. -}
pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)
pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool)
pipeNullSplit params repo = do
(s, cleanup) <- pipeReadLazy params repo
return (filter (not . null) $ splitc sep s, cleanup)
where
sep = '\0'
return (filter (not . L.null) $ L.split 0 s, cleanup)
pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]
{- Reads lazily, but copies each part to a strict ByteString for
- convenience.
-}
pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool)
pipeNullSplit' params repo = do
(s, cleanup) <- pipeNullSplit params repo
return (map L.toStrict s, cleanup)
pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString]
pipeNullSplitStrict params repo = do
s <- pipeReadStrict params repo
return $ filter (not . null) $ splitc sep s
where
sep = '\0'
return $ filter (not . S.null) $ S.split 0 s
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString]
pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo
{- Doesn't run the cleanup action. A zombie results. -}
leaveZombie :: (a, IO Bool) -> a
leaveZombie = fst

View file

@ -1,13 +1,17 @@
{- git repository configuration handling
-
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Git.Config where
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Char
import Common
@ -17,16 +21,16 @@ import qualified Git.Command
import qualified Git.Construct
import Utility.UserInfo
{- Returns a single git config setting, or a default value if not set. -}
get :: String -> String -> Repo -> String
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
{- Returns a single git config setting, or a fallback value if not set. -}
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
get key fallback repo = M.findWithDefault fallback key (config repo)
{- Returns a list with each line of a multiline config setting. -}
getList :: String -> Repo -> [String]
{- Returns a list of values. -}
getList :: ConfigKey -> Repo -> [ConfigValue]
getList key repo = M.findWithDefault [] key (fullconfig repo)
{- Returns a single git config setting, if set. -}
getMaybe :: String -> Repo -> Maybe String
getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
getMaybe key repo = M.lookup key (config repo)
{- Runs git config and populates a repo with its config.
@ -79,14 +83,14 @@ global = do
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
hRead repo h = do
val <- hGetContentsStrict h
val <- S.hGetContents h
store val repo
{- Stores a git config into a Repo, returning the new version of the Repo.
- The git config may be multiple lines, or a single line.
- Config settings can be updated incrementally.
-}
store :: String -> Repo -> IO Repo
store :: S.ByteString -> Repo -> IO Repo
store s repo = do
let c = parse s
updateLocation $ repo
@ -96,7 +100,7 @@ store s repo = do
{- Stores a single config setting in a Repo, returning the new version of
- the Repo. Config settings can be updated incrementally. -}
store' :: String -> String -> Repo -> Repo
store' :: ConfigKey -> ConfigValue -> Repo -> Repo
store' k v repo = repo
{ config = M.singleton k v `M.union` config repo
, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
@ -124,52 +128,66 @@ updateLocation' :: Repo -> RepoLocation -> IO Repo
updateLocation' r l = do
l' <- case getMaybe "core.worktree" r of
Nothing -> return l
Just d -> do
Just (ConfigValue d) -> do
{- core.worktree is relative to the gitdir -}
top <- absPath $ gitdir l
return $ l { worktree = Just $ absPathFrom top d }
let p = absPathFrom top (fromRawFilePath d)
return $ l { worktree = Just p }
return $ r { location = l' }
{- Parses git config --list or git config --null --list output into a
- config map. -}
parse :: String -> M.Map String [String]
parse [] = M.empty
parse :: S.ByteString -> M.Map ConfigKey [ConfigValue]
parse s
-- --list output will have an = in the first line
| all ('=' `elem`) (take 1 ls) = sep '=' ls
| S.null s = M.empty
-- --list output will have a '=' in the first line
-- (The first line of --null --list output is the name of a key,
-- which is assumed to never contain '='.)
| S.elem eq firstline = sep eq $ S.split nl s
-- --null --list output separates keys from values with newlines
| otherwise = sep '\n' $ splitc '\0' s
| otherwise = sep nl $ S.split 0 s
where
ls = lines s
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
map (separate (== c))
nl = fromIntegral (ord '\n')
eq = fromIntegral (ord '=')
firstline = S.takeWhile (/= nl) s
sep c = M.fromListWith (++)
. map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)]))
. map (S.break (== c))
{- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool
isTrue s
isTrue = isTrue' . ConfigValue . encodeBS'
isTrue' :: ConfigValue -> Maybe Bool
isTrue' (ConfigValue s)
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
where
s' = map toLower s
s' = S8.map toLower s
boolConfig :: Bool -> String
boolConfig True = "true"
boolConfig False = "false"
isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
boolConfig' :: Bool -> S.ByteString
boolConfig' True = "true"
boolConfig' False = "false"
coreBare :: String
isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue' =<< getMaybe coreBare r
coreBare :: ConfigKey
coreBare = "core.bare"
{- Runs a command to get the configuration of a repo,
- and returns a repo populated with the configuration, as well as the raw
- output of the command. -}
fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String))
fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString))
fromPipe r cmd params = try $
withHandle StdoutHandle createProcessSuccess p $ \h -> do
val <- hGetContentsStrict h
val <- S.hGetContents h
r' <- store val r
return (r', val)
where
@ -177,7 +195,7 @@ fromPipe r cmd params = try $
{- Reads git config from a specified file and returns the repo populated
- with the configuration. -}
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString))
fromFile r f = fromPipe r "git"
[ Param "config"
, Param "--file"
@ -187,13 +205,13 @@ fromFile r f = fromPipe r "git"
{- Changes a git config setting in the specified config file.
- (Creates the file if it does not already exist.) -}
changeFile :: FilePath -> String -> String -> IO Bool
changeFile f k v = boolSystem "git"
changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
changeFile f (ConfigKey k) v = boolSystem "git"
[ Param "config"
, Param "--file"
, File f
, Param k
, Param v
, Param (decodeBS' k)
, Param (decodeBS' v)
]
{- Unsets a git config setting, in both the git repo,
@ -202,10 +220,10 @@ changeFile f k v = boolSystem "git"
- If unsetting the config fails, including in a read-only repo, or
- when the config is not set, returns Nothing.
-}
unset :: String -> Repo -> IO (Maybe Repo)
unset k r = ifM (Git.Command.runBool ps r)
( return $ Just $ r { config = M.delete k (config r) }
unset :: ConfigKey -> Repo -> IO (Maybe Repo)
unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
( return $ Just $ r { config = M.delete ck (config r) }
, return Nothing
)
where
ps = [Param "config", Param "--unset-all", Param k]
ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]

View file

@ -5,12 +5,16 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Git.ConfigTypes where
import Data.Char
import qualified Data.ByteString.Char8 as S8
import Common
import Git
import Git.Types
import qualified Git.Config
data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
@ -18,23 +22,27 @@ data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
getSharedRepository :: Repo -> SharedRepository
getSharedRepository r =
case map toLower $ Git.Config.get "core.sharedrepository" "" r of
"1" -> GroupShared
"2" -> AllShared
"group" -> GroupShared
"true" -> GroupShared
"all" -> AllShared
"world" -> AllShared
"everybody" -> AllShared
v -> maybe UnShared UmaskShared (readish v)
case Git.Config.getMaybe "core.sharedrepository" r of
Nothing -> UnShared
Just (ConfigValue v) -> case S8.map toLower v of
"1" -> GroupShared
"2" -> AllShared
"group" -> GroupShared
"true" -> GroupShared
"all" -> AllShared
"world" -> AllShared
"everybody" -> AllShared
_ -> maybe UnShared UmaskShared (readish (decodeBS' v))
data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush
deriving (Eq)
getDenyCurrentBranch :: Repo -> DenyCurrentBranch
getDenyCurrentBranch r =
case map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of
"updateinstead" -> UpdateInstead
"warn" -> WarnPush
"ignore" -> IgnorePush
_ -> RefusePush
getDenyCurrentBranch r =
case Git.Config.getMaybe "receive.denycurrentbranch" r of
Just (ConfigValue v) -> case S8.map toLower v of
"updateinstead" -> UpdateInstead
"warn" -> WarnPush
"ignore" -> IgnorePush
_ -> RefusePush
Nothing -> RefusePush

View file

@ -58,7 +58,7 @@ fromPath dir = fromAbsPath =<< absPath dir
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
| absoluteGitPath dir = hunt
| absoluteGitPath (encodeBS dir) = hunt
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
@ -128,7 +128,7 @@ fromRemotes repo = mapM construct remotepairs
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isRemoteKey
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
@ -138,7 +138,7 @@ remoteNamed n constructor = do
{- Sets the name of a remote based on the git config key, such as
- "remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo
remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
{- Constructs a new Repo for one of a Repo's remotes using a given

View file

@ -89,7 +89,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 diff, cleanup)
return (parseDiffRaw (map decodeBL diff), cleanup)
where
ps =
command :
@ -113,7 +113,7 @@ parseDiffRaw l = go l
, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
, status = s
, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f
, file = asTopFilePath $ fromRawFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f
}
where
readmode = fst . Prelude.head . readOct

View file

@ -12,6 +12,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.FilePath (
TopFilePath,
@ -33,8 +34,9 @@ import Git
import qualified System.FilePath.Posix
import GHC.Generics
import Control.DeepSeq
import qualified Data.ByteString as S
{- A FilePath, relative to the top of the git repository. -}
{- A RawFilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
deriving (Show, Eq, Ord, Generic)
@ -45,8 +47,9 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
deriving (Show, Eq, Ord)
{- Git uses the branch:file form to refer to a BranchFilePath -}
descBranchFilePath :: BranchFilePath -> String
descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f
descBranchFilePath :: BranchFilePath -> S.ByteString
descBranchFilePath (BranchFilePath b f) =
encodeBS' (fromRef b) <> ":" <> toRawFilePath (getTopFilePath f)
{- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
@ -68,25 +71,25 @@ asTopFilePath file = TopFilePath file
- despite Windows using '\'.
-
-}
type InternalGitPath = String
type InternalGitPath = RawFilePath
toInternalGitPath :: FilePath -> InternalGitPath
toInternalGitPath :: RawFilePath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
toInternalGitPath = replace "\\" "/"
toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS
#endif
fromInternalGitPath :: InternalGitPath -> FilePath
fromInternalGitPath :: InternalGitPath -> RawFilePath
#ifndef mingw32_HOST_OS
fromInternalGitPath = id
#else
fromInternalGitPath = replace "/" "\\"
fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS
#endif
{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,
- so try posix paths.
-}
absoluteGitPath :: FilePath -> Bool
absoluteGitPath p = isAbsolute p ||
System.FilePath.Posix.isAbsolute (toInternalGitPath p)
absoluteGitPath :: RawFilePath -> Bool
absoluteGitPath p = isAbsolute (decodeBS p) ||
System.FilePath.Posix.isAbsolute (decodeBS (toInternalGitPath p))

View file

@ -12,23 +12,44 @@ import Common
import Utility.Format (decode_c, encode_c)
import Data.Char
import Data.Word
import qualified Data.ByteString as S
decode :: String -> FilePath
decode [] = []
decode f@(c:s)
-- encoded strings will be inside double quotes
| c == '"' && end s == ['"'] = decode_c $ beginning s
| otherwise = f
-- encoded filenames will be inside double quotes
decode :: S.ByteString -> RawFilePath
decode b = case S.uncons b of
Nothing -> b
Just (h, t)
| h /= q -> b
| otherwise -> case S.unsnoc t of
Nothing -> b
Just (i, l)
| l /= q -> b
| otherwise ->
encodeBS $ decode_c $ decodeBS i
where
q :: Word8
q = fromIntegral (ord '"')
{- Should not need to use this, except for testing decode. -}
encode :: FilePath -> String
encode s = "\"" ++ encode_c s ++ "\""
encode :: RawFilePath -> S.ByteString
encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""
{- For quickcheck.
-
- See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for
- why this only tests chars < 256 -}
prop_encode_decode_roundtrip :: String -> Bool
prop_encode_decode_roundtrip s = s' == decode (encode s')
prop_encode_decode_roundtrip :: FilePath -> Bool
prop_encode_decode_roundtrip s = s' ==
fromRawFilePath (decode (encode (toRawFilePath s')))
where
s' = filter (\c -> ord c < 256) s
s' = nonul (nohigh s)
-- Encoding and then decoding roundtrips only when
-- the string does not contain high unicode, because eg,
-- both "\12345" and "\227\128\185" are encoded to
-- "\343\200\271".
--
-- This property papers over the problem, by only
-- testing chars < 256.
nohigh = filter (\c -> ord c < 256)
-- A String can contain a NUL, but toRawFilePath
-- truncates on the NUL, which is generally fine
-- because unix filenames cannot contain NUL.
-- So the encoding only roundtrips when there is no nul.
nonul = filter (/= '\NUL')

View file

@ -7,6 +7,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Git.GCrypt where
import Common
@ -16,6 +18,8 @@ import qualified Git.Config as Config
import qualified Git.Command as Command
import Utility.Gpg
import qualified Data.ByteString as S
urlScheme :: String
urlScheme = "gcrypt:"
@ -75,9 +79,9 @@ type GCryptId = String
- which is stored in the repository (in encrypted form)
- and cached in a per-remote gcrypt-id configuration setting. -}
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId
remoteRepoId = getRemoteConfig "gcrypt-id"
remoteRepoId r n = fromConfigValue <$> getRemoteConfig "gcrypt-id" r n
getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String
getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe ConfigValue
getRemoteConfig field repo remotename = do
n <- remotename
Config.getMaybe (remoteConfigKey field n) repo
@ -92,18 +96,19 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust
]
where
defaultkey = "gcrypt.participants"
parse (Just "simple") = []
parse (Just l) = words l
parse (Just (ConfigValue "simple")) = []
parse (Just (ConfigValue b)) = words (decodeBS' b)
parse Nothing = []
remoteParticipantConfigKey :: RemoteName -> String
remoteParticipantConfigKey :: RemoteName -> ConfigKey
remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants"
remotePublishParticipantConfigKey :: RemoteName -> String
remotePublishParticipantConfigKey :: RemoteName -> ConfigKey
remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants"
remoteSigningKey :: RemoteName -> String
remoteSigningKey :: RemoteName -> ConfigKey
remoteSigningKey = remoteConfigKey "gcrypt-signingkey"
remoteConfigKey :: String -> RemoteName -> String
remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key
remoteConfigKey :: S.ByteString -> RemoteName -> ConfigKey
remoteConfigKey key remotename = ConfigKey $
"remote." <> encodeBS' remotename <> "." <> key

View file

@ -73,4 +73,4 @@ hashObject' objtype writer repo = getSha subcmd $
pipeWriteRead (map Param params) (Just writer) repo
where
subcmd = "hash-object"
params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"]
params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"]

View file

@ -38,37 +38,40 @@ import Utility.TimeStamp
import Numeric
import System.Posix.Types
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
{- Scans for files that are checked into git's index at the specified locations. -}
inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepo = inRepo' []
inRepo' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
inRepo' ps l = pipeNullSplit $
Param "ls-files" :
Param "--cached" :
Param "-z" :
ps ++
(Param "--" : map File l)
inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepo' ps l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
Param "--cached" :
Param "-z" :
ps ++
(Param "--" : map (File . fromRawFilePath) l)
{- Files that are checked into the index or have been committed to a
- branch. -}
inRepoOrBranch :: Branch -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]
{- Scans for files at the specified locations that are not checked into git. -}
notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo = notInRepo' []
notInRepo' :: [CommandParam] -> Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
notInRepo' ps include_ignored l repo = pipeNullSplit params repo
notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepo' ps include_ignored l repo = pipeNullSplit' params repo
where
params = concat
[ [ Param "ls-files", Param "--others"]
, ps
, exclude
, [ Param "-z", Param "--" ]
, map File l
, map (File . fromRawFilePath) l
]
exclude
| include_ignored = []
@ -76,48 +79,48 @@ notInRepo' ps include_ignored l repo = pipeNullSplit params repo
{- Scans for files at the specified locations that are not checked into
- git. Empty directories are included in the result. -}
notInRepoIncludingEmptyDirectories :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]
{- Finds all files in the specified locations, whether checked into git or
- not. -}
allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
allFiles l = pipeNullSplit $
allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
allFiles l = pipeNullSplit' $
Param "ls-files" :
Param "--cached" :
Param "--others" :
Param "-z" :
Param "--" :
map File l
map (File . fromRawFilePath) l
{- Returns a list of files in the specified locations that have been
- deleted. -}
deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
deleted l repo = pipeNullSplit params repo
deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
deleted l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
Param "--deleted" :
Param "-z" :
Param "--" :
map File l
map (File . fromRawFilePath) l
{- Returns a list of files in the specified locations that have been
- modified. -}
modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
modified l repo = pipeNullSplit params repo
modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
modified l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
Param "--modified" :
Param "-z" :
Param "--" :
map File l
map (File . fromRawFilePath) l
{- Files that have been modified or are not checked into git (and are not
- ignored). -}
modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
modifiedOthers l repo = pipeNullSplit params repo
modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
modifiedOthers l repo = pipeNullSplit' params repo
where
params =
Param "ls-files" :
@ -126,69 +129,69 @@ modifiedOthers l repo = pipeNullSplit params repo
Param "--exclude-standard" :
Param "-z" :
Param "--" :
map File l
map (File . fromRawFilePath) l
{- Returns a list of all files that are staged for commit. -}
staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
staged = staged' []
{- Returns a list of the files, staged for commit, that are being added,
- moved, or changed (but not deleted), from the specified locations. -}
stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo
where
prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]
suffix = Param "--" : map File l
suffix = Param "--" : map (File . fromRawFilePath) l
type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)
type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode)
{- Returns details about files that are staged in the index,
- as well as files not yet in git. Skips ignored files. -}
stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]
{- Returns details about all files that are staged in the index. -}
stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails = stagedDetails' []
{- Gets details about staged files, including the Sha of their staged
- contents. -}
stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)
stagedDetails' ps l repo = do
(ls, cleanup) <- pipeNullSplit params repo
return (map parse ls, cleanup)
where
params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++
Param "--" : map File l
Param "--" : map (File . fromRawFilePath) l
parse s
| null file = (s, Nothing, Nothing)
| otherwise = (file, extractSha $ take shaSize rest, readmode mode)
| null file = (L.toStrict s, Nothing, Nothing)
| otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode)
where
(metadata, file) = separate (== '\t') s
(metadata, file) = separate (== '\t') (decodeBL' s)
(mode, rest) = separate (== ' ') metadata
readmode = fst <$$> headMaybe . readOct
{- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -}
typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChangedStaged = typeChanged' [Param "--cached"]
{- Returns a list of the files in the specified locations whose type has
- changed. Files only staged for commit will not be included. -}
typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged = typeChanged' []
typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)
typeChanged' ps l repo = do
(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo
-- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files.
top <- absPath (repoPath repo)
currdir <- getCurrentDirectory
return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)
return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)
where
prefix =
[ Param "diff"
@ -196,7 +199,7 @@ typeChanged' ps l repo = do
, Param "--diff-filter=T"
, Param "-z"
]
suffix = Param "--" : (if null l then [File "."] else map File l)
suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l)
{- A item in conflict has two possible values.
- Either can be Nothing, when that side deleted the file. -}
@ -206,7 +209,7 @@ data Conflicting v = Conflicting
} deriving (Show)
data Unmerged = Unmerged
{ unmergedFile :: FilePath
{ unmergedFile :: RawFilePath
, unmergedTreeItemType :: Conflicting TreeItemType
, unmergedSha :: Conflicting Sha
}
@ -221,21 +224,21 @@ data Unmerged = Unmerged
- 3 = them
- If a line is omitted, that side removed the file.
-}
unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = do
(fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
where
params =
Param "ls-files" :
Param "--unmerged" :
Param "-z" :
Param "--" :
map File l
map (File . fromRawFilePath) l
data InternalUnmerged = InternalUnmerged
{ isus :: Bool
, ifile :: FilePath
, ifile :: RawFilePath
, itreeitemtype :: Maybe TreeItemType
, isha :: Maybe Sha
}
@ -249,9 +252,9 @@ parseUnmerged s
if stage /= 2 && stage /= 3
then Nothing
else do
treeitemtype <- readTreeItemType rawtreeitemtype
treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha rawsha
return $ InternalUnmerged (stage == 2) file
return $ InternalUnmerged (stage == 2) (toRawFilePath file)
(Just treeitemtype) (Just sha)
_ -> Nothing
where
@ -285,10 +288,10 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
- Note that this uses a --debug option whose output could change at some
- point in the future. If the output is not as expected, will use Nothing.
-}
inodeCaches :: [FilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)
inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)
inodeCaches locs repo = do
(ls, cleanup) <- pipeNullSplit params repo
return (parse Nothing ls, cleanup)
return (parse Nothing (map decodeBL ls), cleanup)
where
params =
Param "ls-files" :
@ -296,7 +299,7 @@ inodeCaches locs repo = do
Param "-z" :
Param "--debug" :
Param "--" :
map File locs
map (File . fromRawFilePath) locs
parse Nothing (f:ls) = parse (Just f) ls
parse (Just f) (s:[]) =

View file

@ -24,14 +24,19 @@ import Git.Command
import Git.Sha
import Git.FilePath
import qualified Git.Filename
import Utility.Attoparsec
import Numeric
import Data.Char
import Data.Either
import System.Posix.Types
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Attoparsec.ByteString.Lazy as A
import qualified Data.Attoparsec.ByteString.Char8 as A8
data TreeItem = TreeItem
{ mode :: FileMode
, typeobj :: String
, typeobj :: S.ByteString
, sha :: Ref
, file :: TopFilePath
} deriving Show
@ -45,7 +50,7 @@ lsTree = lsTree' []
lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
lsTree' ps lsmode t repo = do
(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
return (map parseLsTree l, cleanup)
return (rights (map parseLsTree l), cleanup)
lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
lsTreeParams lsmode r ps =
@ -63,7 +68,8 @@ lsTreeParams lsmode r ps =
{- Lists specified files in a tree. -}
lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
<$> pipeNullSplitStrict ps repo
where
ps =
[ Param "ls-tree"
@ -73,30 +79,34 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
, File $ fromRef t
] ++ map File fs
parseLsTree :: L.ByteString -> Either String TreeItem
parseLsTree b = case A.parse parserLsTree b of
A.Done _ r -> Right r
A.Fail _ _ err -> Left err
{- Parses a line of ls-tree output, in format:
- mode SP type SP sha TAB file
-
- (The --long format is not currently supported.) -}
parseLsTree :: String -> TreeItem
parseLsTree l = TreeItem
{ mode = smode
, typeobj = t
, sha = Ref s
, file = sfile
}
where
(m, past_m) = splitAt 7 l -- mode is 6 bytes
(!t, past_t) = separate isSpace past_m
(!s, past_s) = splitAt shaSize past_t
!f = drop 1 past_s
!smode = fst $ Prelude.head $ readOct m
!sfile = asTopFilePath $ Git.Filename.decode f
parserLsTree :: A.Parser TreeItem
parserLsTree = TreeItem
-- mode
<$> octal
<* A8.char ' '
-- type
<*> A.takeTill (== 32)
<* A8.char ' '
-- sha
<*> (Ref . decodeBS' <$> A.take shaSize)
<* A8.char '\t'
-- file
<*> (asTopFilePath . decodeBS' . Git.Filename.decode <$> A.takeByteString)
{- Inverse of parseLsTree -}
formatLsTree :: TreeItem -> String
formatLsTree ti = unwords
[ showOct (mode ti) ""
, typeobj ti
, decodeBS (typeobj ti)
, fromRef (sha ti)
, getTopFilePath (file ti)
]

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Git.Ref where
import Common
@ -13,7 +15,8 @@ import Git.Command
import Git.Sha
import Git.Types
import Data.Char (chr)
import Data.Char (chr, ord)
import qualified Data.ByteString as S
headRef :: Ref
headRef = Ref "HEAD"
@ -62,8 +65,8 @@ branchRef = underBase "refs/heads"
- Prefixing the file with ./ makes this work even if in a subdirectory
- of a repo.
-}
fileRef :: FilePath -> Ref
fileRef f = Ref $ ":./" ++ f
fileRef :: RawFilePath -> Ref
fileRef f = Ref $ ":./" ++ fromRawFilePath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
@ -71,7 +74,7 @@ dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
{- A Ref that can be used to refer to a file in the repository as it
- appears in a given Ref. -}
fileFromRef :: Ref -> FilePath -> Ref
fileFromRef :: Ref -> RawFilePath -> Ref
fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
{- Checks if a ref exists. -}
@ -88,8 +91,10 @@ file ref repo = localGitDir repo </> fromRef ref
- that was just created. -}
headExists :: Repo -> IO Bool
headExists repo = do
ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo
return $ any (" HEAD" `isSuffixOf`) ls
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)
@ -100,8 +105,9 @@ sha branch repo = process <$> showref repo
, Param "--hash" -- get the hash
, Param $ fromRef branch
]
process [] = Nothing
process s = Just $ Ref $ firstLine s
process s
| S.null s = Nothing
| otherwise = Just $ Ref $ decodeBS' $ firstLine' s
headSha :: Repo -> IO (Maybe Sha)
headSha = sha headRef
@ -116,7 +122,7 @@ matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
{- List of (shas, branches) matching a given ref spec. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
matching' ps repo = map gen . lines <$>
matching' ps repo = map gen . lines . decodeBS' <$>
pipeReadStrict (Param "show-ref" : map Param ps) repo
where
gen l = let (r, b) = separate (== ' ') l
@ -148,7 +154,7 @@ 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 <$$> pipeReadStrict
tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict
[ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]
where
ref' = if ":" `isInfixOf` ref

View file

@ -21,7 +21,7 @@ getMulti :: [Branch] -> Repo -> IO [Sha]
getMulti bs = get' (map (Param . fromRef) bs)
get' :: [CommandParam] -> Repo -> IO [Sha]
get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps'
get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'
where
ps' = catMaybes
[ Just $ Param "log"

View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.Remote where
@ -15,18 +16,21 @@ import Git.Types
import Data.Char
import qualified Data.Map as M
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Network.URI
#ifdef mingw32_HOST_OS
import Git.FilePath
#endif
{- Is a git config key one that specifies the location of a remote? -}
isRemoteKey :: String -> Bool
isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
isRemoteKey :: ConfigKey -> Bool
isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k
{- Get a remote's name from the config key that specifies its location. -}
remoteKeyToRemoteName :: String -> RemoteName
remoteKeyToRemoteName k = intercalate "." $ dropFromEnd 1 $ drop 1 $ splitc '.' k
remoteKeyToRemoteName :: ConfigKey -> RemoteName
remoteKeyToRemoteName (ConfigKey k) = decodeBS' $
S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
{- Construct a legal git remote name out of an arbitrary input string.
-
@ -76,16 +80,16 @@ parseRemoteLocation s repo = ret $ calcloc s
-- insteadof config can rewrite remote location
calcloc l
| null insteadofs = l
| otherwise = replacement ++ drop (length bestvalue) l
| otherwise = replacement ++ drop (S.length bestvalue) l
where
replacement = drop (length prefix) $
take (length bestkey - length suffix) bestkey
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
replacement = decodeBS' $ S.drop (S.length prefix) $
S.take (S.length bestkey - S.length suffix) bestkey
(ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs
longestvalue (_, a) (_, b) = compare b a
insteadofs = filterconfig $ \(k, v) ->
prefix `isPrefixOf` k &&
suffix `isSuffixOf` k &&
v `isPrefixOf` l
insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) ->
prefix `S.isPrefixOf` k &&
suffix `S.isSuffixOf` k &&
v `S.isPrefixOf` encodeBS l
filterconfig f = filter f $
concatMap splitconfigs $ M.toList $ fullconfig repo
splitconfigs (k, vs) = map (\v -> (k, v)) vs

View file

@ -284,7 +284,7 @@ findUncorruptedCommit missing goodcommits branch r = do
, Param "--format=%H"
, Param (fromRef branch)
] r
let branchshas = catMaybes $ map extractSha ls
let branchshas = catMaybes $ map (extractSha . decodeBL) ls
reflogshas <- RefLog.get branch r
-- XXX Could try a bit harder here, and look
-- for uncorrupted old commits in branches in the
@ -313,7 +313,7 @@ verifyCommit missing goodcommits commit r
, Param "--format=%H %T"
, Param (fromRef commit)
] r
let committrees = map parse ls
let committrees = map (parse . decodeBL) ls
if any isNothing committrees || null committrees
then do
void cleanup
@ -342,7 +342,7 @@ verifyTree missing treesha r
| S.member treesha missing = return False
| otherwise = do
(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r
let objshas = map (LsTree.sha . LsTree.parseLsTree) ls
let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls
if any (`S.member` missing) objshas
then do
void cleanup
@ -366,7 +366,7 @@ checkIndex r = do
- itself is not corrupt. -}
checkIndexFast :: Repo -> IO Bool
checkIndexFast r = do
(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
(indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r
length indexcontents `seq` cleanup
missingIndex :: Repo -> IO Bool
@ -375,7 +375,7 @@ missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
{- Finds missing and ok files staged in the index. -}
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
partitionIndex r = do
(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
(indexcontents, cleanup) <- LsFiles.stagedDetails [toRawFilePath (repoPath r)] r
l <- forM indexcontents $ \i -> case i of
(_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i
_ -> pure (False, i)
@ -394,12 +394,12 @@ rewriteIndex r
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
return $ map fst3 bad
return $ map (fromRawFilePath . fst3) bad
where
reinject (file, Just sha, Just mode) = case toTreeItemType mode of
Nothing -> return Nothing
Just treeitemtype -> Just <$>
UpdateIndex.stageFile sha treeitemtype file r
UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r
reinject _ = return Nothing
newtype GoodCommits = GoodCommits (S.Set Sha)

View file

@ -69,7 +69,7 @@ parseStatusZ = go []
getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool)
getStatus ps fs r = do
(ls, cleanup) <- pipeNullSplit ps' r
return (parseStatusZ ls, cleanup)
return (parseStatusZ (map decodeBL ls), cleanup)
where
ps' = concat
[ [Param "status"]

View file

@ -115,7 +115,7 @@ mkTreeOutput :: FileMode -> ObjectType -> Sha -> TopFilePath -> String
mkTreeOutput fm ot s f = concat
[ showOct fm ""
, " "
, show ot
, decodeBS (fmtObjectType ot)
, " "
, fromRef s
, "\t"
@ -134,7 +134,7 @@ treeItemToTreeContent (TreeItem f m s) = case toTreeItemType m of
treeItemToLsTreeItem :: TreeItem -> LsTree.TreeItem
treeItemToLsTreeItem (TreeItem f mode sha) = LsTree.TreeItem
{ LsTree.mode = mode
, LsTree.typeobj = show BlobObject
, LsTree.typeobj = fmtObjectType BlobObject
, LsTree.sha = sha
, LsTree.file = f
}
@ -239,7 +239,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
Just CommitObject -> do
let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
go h wasmodified (ti:c) depth intree is
_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
_ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
| otherwise = return (c, wasmodified, i:is)
adjustlist h depth ishere underhere l = do
@ -328,7 +328,7 @@ graftTree' subtree graftloc basetree repo hdl = go basetree graftdirs
-- For a graftloc of "foo/bar/baz", this generates
-- ["foo", "foo/bar", "foo/bar/baz"]
graftdirs = map (asTopFilePath . toInternalGitPath) $
graftdirs = map (asTopFilePath . decodeBS . toInternalGitPath . encodeBS) $
mkpaths [] $ splitDirectories $ gitPath graftloc
mkpaths _ [] = []
mkpaths base (d:rest) = (joinPath base </> d) : mkpaths (base ++ [d]) rest
@ -355,7 +355,7 @@ extractTree l = case go [] inTopTree l of
Just CommitObject ->
let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
in go (c:t) intree is
_ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
_ -> parseerr ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
| otherwise = Right (t, i:is)
parseerr = Left

View file

@ -1,16 +1,23 @@
{- git data types
-
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Git.Types where
import Network.URI
import Data.String
import Data.Default
import qualified Data.Map as M
import qualified Data.ByteString as S
import System.Posix.Types
import Utility.SafeCommand
import Utility.FileSystemEncoding
{- Support repositories on local disk, and repositories accessed via an URL.
-
@ -31,9 +38,9 @@ data RepoLocation
data Repo = Repo
{ location :: RepoLocation
, config :: M.Map String String
, config :: M.Map ConfigKey ConfigValue
-- a given git config key can actually have multiple values
, fullconfig :: M.Map String [String]
, fullconfig :: M.Map ConfigKey [ConfigValue]
-- remoteName holds the name used for this repo in some other
-- repo's list of remotes, when this repo is such a remote
, remoteName :: Maybe RemoteName
@ -44,6 +51,33 @@ data Repo = Repo
, gitGlobalOpts :: [CommandParam]
} deriving (Show, Eq, Ord)
newtype ConfigKey = ConfigKey S.ByteString
deriving (Ord, Eq)
newtype ConfigValue = ConfigValue S.ByteString
deriving (Ord, Eq, Semigroup, Monoid)
instance Default ConfigValue where
def = ConfigValue mempty
fromConfigKey :: ConfigKey -> String
fromConfigKey (ConfigKey s) = decodeBS' s
instance Show ConfigKey where
show = fromConfigKey
fromConfigValue :: ConfigValue -> String
fromConfigValue (ConfigValue s) = decodeBS' s
instance Show ConfigValue where
show = fromConfigValue
instance IsString ConfigKey where
fromString = ConfigKey . encodeBS'
instance IsString ConfigValue where
fromString = ConfigValue . encodeBS'
type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
@ -64,32 +98,31 @@ newtype RefDate = RefDate String
{- Types of objects that can be stored in git. -}
data ObjectType = BlobObject | CommitObject | TreeObject
deriving (Eq)
instance Show ObjectType where
show BlobObject = "blob"
show CommitObject = "commit"
show TreeObject = "tree"
readObjectType :: String -> Maybe ObjectType
readObjectType :: S.ByteString -> Maybe ObjectType
readObjectType "blob" = Just BlobObject
readObjectType "commit" = Just CommitObject
readObjectType "tree" = Just TreeObject
readObjectType _ = Nothing
fmtObjectType :: ObjectType -> S.ByteString
fmtObjectType BlobObject = "blob"
fmtObjectType CommitObject = "commit"
fmtObjectType TreeObject = "tree"
{- Types of items in a tree. -}
data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule
deriving (Eq)
deriving (Eq, Show)
{- Git uses magic numbers to denote the type of a tree item. -}
readTreeItemType :: String -> Maybe TreeItemType
readTreeItemType :: S.ByteString -> Maybe TreeItemType
readTreeItemType "100644" = Just TreeFile
readTreeItemType "100755" = Just TreeExecutable
readTreeItemType "120000" = Just TreeSymlink
readTreeItemType "160000" = Just TreeSubmodule
readTreeItemType _ = Nothing
fmtTreeItemType :: TreeItemType -> String
fmtTreeItemType :: TreeItemType -> S.ByteString
fmtTreeItemType TreeFile = "100644"
fmtTreeItemType TreeExecutable = "100755"
fmtTreeItemType TreeSymlink = "120000"

View file

@ -10,6 +10,7 @@ module Git.UnionMerge (
mergeIndex
) where
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Set as S
@ -69,7 +70,7 @@ diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
doMerge :: HashObjectHandle -> CatFileHandle -> [String] -> Repo -> Streamer
doMerge hashhandle ch differ repo streamer = do
(diff, cleanup) <- pipeNullSplit (map Param differ) repo
go diff
go (map decodeBL' diff)
void $ cleanup
where
go [] = noop
@ -80,7 +81,7 @@ doMerge hashhandle ch differ repo streamer = do
{- 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 -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe String)
mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of
[] -> return Nothing
(sha:[]) -> use sha

View file

@ -1,11 +1,11 @@
{- git-update-index library
-
- Copyright 2011-2018 Joey Hess <id@joeyh.name>
- Copyright 2011-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns, CPP #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}
module Git.UpdateIndex (
Streamer,
@ -32,12 +32,14 @@ import Git.FilePath
import Git.Sha
import qualified Git.DiffTreeItem as Diff
import qualified Data.ByteString.Lazy as L
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
type Streamer = (String -> IO ()) -> IO ()
type Streamer = (L.ByteString -> IO ()) -> IO ()
{- A streamer with a precalculated value. -}
pureStreamer :: String -> Streamer
pureStreamer :: L.ByteString -> Streamer
pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
@ -49,8 +51,8 @@ data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
hPutStr h s
hPutStr h "\0"
L.hPutStr h s
L.hPutStr h "\0"
startUpdateIndex :: Repo -> IO UpdateIndexHandle
startUpdateIndex repo = do
@ -84,14 +86,13 @@ lsSubTree (Ref x) p repo streamer = do
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String
updateIndexLine sha treeitemtype file = concat
[ fmtTreeItemType treeitemtype
, " blob "
, fromRef sha
, "\t"
, indexPath file
]
updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
updateIndexLine sha treeitemtype file = L.fromStrict $
fmtTreeItemType treeitemtype
<> " blob "
<> encodeBS (fromRef sha)
<> "\t"
<> indexPath file
stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
stageFile sha treeitemtype file repo = do
@ -105,7 +106,11 @@ unstageFile file repo = do
return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer
unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
unstageFile' p = pureStreamer $ L.fromStrict $
"0 "
<> encodeBS' (fromRef nullSha)
<> "\t"
<> indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
@ -123,7 +128,7 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath
indexPath = toInternalGitPath . toRawFilePath . getTopFilePath
{- Refreshes the index, by checking file stat information. -}
refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool