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:
commit
2f9a80d803
266 changed files with 2860 additions and 1325 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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')
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"]
|
||||
|
|
111
Git/LsFiles.hs
111
Git/LsFiles.hs
|
@ -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:[]) =
|
||||
|
|
|
@ -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)
|
||||
]
|
||||
|
|
26
Git/Ref.hs
26
Git/Ref.hs
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"]
|
||||
|
|
10
Git/Tree.hs
10
Git/Tree.hs
|
@ -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
|
||||
|
||||
|
|
59
Git/Types.hs
59
Git/Types.hs
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue