From 9df8a6eb9405dde4464d27133c04f5ee539a85de Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 2 Jan 2020 12:34:10 -0400 Subject: merge from git-annex and relicense accordingly Merge git library and utility from git-annex. The former is now relicensed AGPL, so git-repair as a whole becomes AGPL. For simplicity, I am relicensing the remainder of the code in git-repair AGPL as well, per the header changes in this commit. While that code is also technically available under the GPL license, as it's been released under that license before, changes going forward will be only released by me under the AGPL. --- Git/Branch.hs | 32 ++++++------ Git/BuildVersion.hs | 2 +- Git/CatFile.hs | 107 +++++++++++++++++++++++++++++++------- Git/Command.hs | 55 +++++++++++++------- Git/Config.hs | 115 +++++++++++++++++++++++++---------------- Git/Construct.hs | 40 +++++++------- Git/CurrentRepo.hs | 44 ++++++++++++---- Git/Destroyer.hs | 4 +- Git/DiffTreeItem.hs | 2 +- Git/FilePath.hs | 55 ++++++++++++-------- Git/Filename.hs | 53 +++++++++++++------ Git/Fsck.hs | 61 +++++++++++----------- Git/HashObject.hs | 76 +++++++++++++++++++++++++++ Git/Index.hs | 32 ++++-------- Git/LsFiles.hs | 146 ++++++++++++++++++++++++++++++---------------------- Git/LsTree.hs | 85 +++++++++++++++++++----------- Git/Objects.hs | 4 +- Git/Ref.hs | 64 ++++++++++++++--------- Git/RefLog.hs | 4 +- Git/Remote.hs | 33 ++++++++---- Git/Repair.hs | 38 +++++++------- Git/Sha.hs | 2 +- Git/Types.hs | 119 +++++++++++++++++++++++++++--------------- Git/UpdateIndex.hs | 71 ++++++++++++++++++------- Git/Url.hs | 10 +++- Git/Version.hs | 2 +- 26 files changed, 825 insertions(+), 431 deletions(-) create mode 100644 Git/HashObject.hs (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index 875f20f..699fbf5 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -2,10 +2,11 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Branch where @@ -15,13 +16,14 @@ import Git.Sha import Git.Command import qualified Git.Config import qualified Git.Ref -import qualified Git.BuildVersion + +import qualified Data.ByteString as B {- The currently checked out branch. - - In a just initialized git repo before the first commit, - symbolic-ref will show the master branch, even though that - - branch is not created yet. So, this also looks at show-ref HEAD + - branch is not created yet. So, this also looks at show-ref - to double-check. -} current :: Repo -> IO (Maybe Branch) @@ -30,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. -} @@ -54,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" @@ -73,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 @@ -125,8 +128,7 @@ data CommitMode = ManualCommit | AutomaticCommit {- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps - | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = - Param "--no-gpg-sign" : ps + | commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps | otherwise = ps {- Some versions of git commit-tree honor commit.gpgsign themselves, @@ -134,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.isTrueFalse' s == Just True -> Param "-S":ps _ -> ps' | otherwise = ps' @@ -162,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 diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs index 7d1c53a..f94a892 100644 --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.BuildVersion where diff --git a/Git/CatFile.hs b/Git/CatFile.hs index ba68c4e..6402001 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,8 +1,8 @@ {- git cat-file interface - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CatFile ( @@ -28,20 +28,23 @@ import Data.String import Data.Char import Numeric import System.Posix.Types +import Text.Read import Common import Git import Git.Sha +import qualified Git.Ref import Git.Command import Git.Types import Git.FilePath +import Git.HashObject import qualified Utility.CoProcess as CoProcess -import Utility.FileSystemEncoding import Utility.Tuple data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle , checkFileProcess :: CoProcess.CoProcessHandle + , gitRepo :: Repo } catFileStart :: Repo -> IO CatFileHandle @@ -51,6 +54,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle <$> startp "--batch" <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> pure repo where startp p = gitCoProcessStart restartable [ Param "cat-file" @@ -63,13 +67,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. -} @@ -77,7 +81,7 @@ catObject :: CatFileHandle -> Ref -> IO L.ByteString catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails h object = query (catFileProcess h) object $ \from -> do +catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do header <- hGetLine from case parseResp object header of Just (ParsedResp sha size objtype) -> do @@ -91,23 +95,53 @@ catObjectDetails h object = query (catFileProcess h) object $ \from -> do c <- hGetChar from when (c /= expected) $ error $ "missing " ++ (show expected) ++ " from git cat-file" + + -- Slow fallback path for filenames containing newlines. + newlinefallback = queryObjectType object (gitRepo h) >>= \case + Nothing -> return Nothing + Just objtype -> queryContent object (gitRepo h) >>= \case + Nothing -> return Nothing + Just content -> do + -- only the --batch interface allows getting + -- the sha, so have to re-hash the object + sha <- hashObject' objtype + (flip L.hPut content) + (gitRepo h) + return (Just (content, sha, objtype)) {- Gets the size and type of an object, without reading its content. -} -catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) -catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do resp <- hGetLine from case parseResp object resp of - Just (ParsedResp _ size objtype) -> - return $ Just (size, objtype) + Just (ParsedResp sha size objtype) -> + return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + where + -- Slow fallback path for filenames containing newlines. + newlinefallback = do + sha <- Git.Ref.sha object (gitRepo h) + sz <- querySize object (gitRepo h) + objtype <- queryObjectType object (gitRepo h) + return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha Integer ObjectType | DNE +data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE -query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a -query hdl object receive = CoProcess.query hdl send receive +query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a +query hdl object newlinefallback receive + -- git cat-file --batch uses a line based protocol, so when the + -- filename itself contains a newline, have to fall back to another + -- method of getting the information. + | '\n' `elem` s = newlinefallback + -- git strips carriage return from the end of a line, out of some + -- misplaced desire to support windows, so also use the newline + -- fallback for those. + | "\r" `isSuffixOf` s = newlinefallback + | otherwise = CoProcess.query hdl send receive where - send to = hPutStrLn to (fromRef object) + send to = hPutStrLn to s + s = fromRef object parseResp :: Ref -> String -> Maybe ParsedResp parseResp object l @@ -116,13 +150,50 @@ 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 | otherwise -> Nothing _ -> Nothing +querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) +querySingle o r repo reader = assertLocal repo $ + -- In non-batch mode, git cat-file warns on stderr when + -- asked for an object that does not exist. + -- Squelch that warning to behave the same as batch mode. + withNullHandle $ \nullh -> do + let p = gitCreateProcess + [ Param "cat-file" + , o + , Param (fromRef r) + ] repo + let p' = p + { std_err = UseHandle nullh + , std_in = Inherit + , std_out = CreatePipe + } + pid <- createProcess p' + let h = stdoutHandle pid + output <- reader h + hClose h + ifM (checkSuccessProcess (processHandle pid)) + ( return (Just output) + , return Nothing + ) + +querySize :: Ref -> Repo -> IO (Maybe FileSize) +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 . encodeBS . takeWhile (/= '\n')) + <$> querySingle (Param "-t") r repo hGetContentsStrict + +queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) +queryContent r repo = fmap (\b -> L.fromChunks [b]) + <$> querySingle (Param "-p") r repo S.hGetContents + {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref @@ -141,7 +212,7 @@ catTree h treeref = go <$> catObjectDetails h treeref dropsha = L.drop 21 parsemodefile b = - let (modestr, file) = separate (== ' ') (decodeBS b) + let (modestr, file) = separate (== ' ') (decodeBL b) in (file, readmode modestr) readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs index f40dfab..eb20af2 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -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 { } ) }) = @@ -21,10 +24,10 @@ gitCommandLine params r@(Repo { location = l@(Local { } ) }) = where setdir | gitEnvOverridesGitDir r = [] - | otherwise = [Param $ "--git-dir=" ++ gitdir l] + | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] settree = case worktree l of Nothing -> [] - Just t -> [Param $ "--work-tree=" ++ t] + Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} @@ -47,13 +50,13 @@ runQuiet params repo = withQuietOutput createProcessSuccess $ {- Runs a git command and returns its output, lazily. - - Also returns an action that should be used when the output is all - - read (or no more is needed), that will wait on the command, and + - 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,10 +65,14 @@ pipeReadLazy params repo = assertLocal repo $ do - - Nonzero exit status is ignored. -} -pipeReadStrict :: [CommandParam] -> Repo -> IO String -pipeReadStrict params repo = assertLocal repo $ +pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString +pipeReadStrict = pipeReadStrict' S.hGetContents + +{- The reader action must be strict. -} +pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a +pipeReadStrict' reader params repo = assertLocal repo $ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - output <- hGetContentsStrict h + output <- reader h hClose h return output where @@ -83,28 +90,36 @@ pipeWriteRead params writer repo = assertLocal repo $ {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () -pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ - gitCreateProcess params repo +pipeWrite params repo = assertLocal repo $ + withHandle StdinHandle createProcessSuccess $ + gitCreateProcess params 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 diff --git a/Git/Config.hs b/Git/Config.hs index 9b4c342..4b60664 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,32 +1,37 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - 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 qualified System.FilePath.ByteString as P import Common import Git import Git.Types -import qualified Git.Construct 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. @@ -57,7 +62,7 @@ read' repo = go repo where params = ["config", "--null", "--list"] p = (proc "git" params) - { cwd = Just d + { cwd = Just (fromRawFilePath d) , env = gitEnv repo } @@ -79,22 +84,28 @@ 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 - repo' <- updateLocation $ repo + updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo) } - rs <- Git.Construct.fromRemotes repo' - return $ repo' { remotes = rs } + +{- Stores a single config setting in a Repo, returning the new version of + - the Repo. Config settings can be updated incrementally. -} +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) + } {- Updates the location of a repo, based on its configuration. - @@ -104,13 +115,13 @@ store s repo = do -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist dotgit) + | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) | otherwise = updateLocation' r $ Local dotgit (Just d) where - dotgit = (d ".git") + dotgit = d P. ".git" updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -118,52 +129,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 } + top <- absPath $ fromRawFilePath (gitdir l) + let p = absPathFrom top (fromRawFilePath d) + return $ l { worktree = Just (toRawFilePath 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 +{- Checks if a string from git config is a true/false value. -} +isTrueFalse :: String -> Maybe Bool +isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' + +isTrueFalse' :: ConfigValue -> Maybe Bool +isTrueFalse' (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" +boolConfig' :: Bool -> S.ByteString +boolConfig' True = "true" +boolConfig' False = "false" + isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r +isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r -coreBare :: String +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 @@ -171,7 +196,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" @@ -181,13 +206,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, @@ -196,10 +221,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)] diff --git a/Git/Construct.hs b/Git/Construct.hs index 4ad74fd..5b656eb 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -58,11 +58,11 @@ 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 - ret = pure . newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown . toRawFilePath canondir = dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} @@ -117,7 +117,7 @@ localToUrl reference r [ Url.scheme reference , "//" , auth - , repoPath r + , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } @@ -127,9 +127,8 @@ fromRemotes repo = mapM construct remotepairs where filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) - remotepairs = filterkeys isremote - isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k - construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + remotepairs = filterkeys isRemoteKey + 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 @@ -139,11 +138,8 @@ 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 k = remoteNamed basename - where - basename = intercalate "." $ - reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo +remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} @@ -158,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo dir' + fromPath $ fromRawFilePath (repoPath repo) dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -208,20 +204,29 @@ checkForRepo dir = where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c - ( return $ Just $ LocalUnknown dir + ( return $ Just $ LocalUnknown $ toRawFilePath dir , return Nothing ) - isRepo = checkdir $ gitSignature $ ".git" "config" + isRepo = checkdir $ + gitSignature (".git" "config") + <||> + -- A git-worktree lacks .git/config, but has .git/commondir. + -- (Normally the .git is a file, not a symlink, but it can + -- be converted to a symlink and git will still work; + -- this handles that case.) + gitSignature (".git" "gitdir") isBareRepo = checkdir $ gitSignature "config" <&&> doesDirectoryExist (dir "objects") gitDirFile = do + -- git-submodule, git-worktree, and --separate-git-dir + -- make .git be a file pointing to the real git directory. c <- firstLine <$> catchDefaultIO "" (readFile $ dir ".git") return $ if gitdirprefix `isPrefixOf` c then Just $ Local - { gitdir = absPathFrom dir $ + { gitdir = toRawFilePath $ absPathFrom dir $ drop (length gitdirprefix) c - , worktree = Just dir + , worktree = Just (toRawFilePath dir) } else Nothing where @@ -233,7 +238,6 @@ newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty - , remotes = [] , remoteName = Nothing , gitEnv = Nothing , gitEnvOverridesGitDir = False diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 69a679e..054a81e 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.CurrentRepo where @@ -12,6 +12,7 @@ import Git.Types import Git.Construct import qualified Git.Config import Utility.Env +import Utility.Env.Set {- Gets the current git repository. - @@ -24,12 +25,20 @@ import Utility.Env - directory if necessary to ensure it is within the repository's work - tree. While not needed for git commands, this is useful for anything - else that looks for files in the worktree. + - + - Also works around a git bug when running some hooks. It + - runs the hooks in the top of the repository, but if GIT_WORK_TREE + - was relative (but not "."), it then points to the wrong directory. + - In this situation GIT_PREFIX contains the directory that + - GIT_WORK_TREE is relative to. -} get :: IO Repo get = do - gd <- pathenv "GIT_DIR" + gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd - wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE" + prefix <- getpathenv "GIT_PREFIX" + wt <- maybe (fromRawFilePath <$> worktree (location r)) Just + <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r Just d -> do @@ -38,22 +47,39 @@ get = do setCurrentDirectory d return $ addworktree wt r where - pathenv s = do + getpathenv s = do v <- getEnv s case v of Just d -> do unsetEnv s - Just <$> absPath d + return (Just d) + Nothing -> return Nothing + + getpathenvprefix s (Just prefix) | not (null prefix) = + getpathenv s >>= \case Nothing -> return Nothing + Just d + | d == "." -> return (Just d) + | otherwise -> Just <$> absPath (prefix d) + getpathenvprefix s _ = getpathenv s configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d curr <- getCurrentDirectory - Git.Config.read $ newFrom $ - Local { gitdir = absd, worktree = Just curr } + r <- Git.Config.read $ newFrom $ + Local + { gitdir = toRawFilePath absd + , worktree = Just (toRawFilePath curr) + } + return $ if Git.Config.isBare r + then r { location = (location r) { worktree = Nothing } } + else r + configure Nothing Nothing = giveup "Not in a git repository." - addworktree w r = changelocation r $ - Local { gitdir = gitdir (location r), worktree = w } + addworktree w r = changelocation r $ Local + { gitdir = gitdir (location r) + , worktree = fmap toRawFilePath w + } changelocation r l = r { location = l } diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index e923796..3dc8529 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -4,7 +4,7 @@ - - Copyright 2013, 2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Destroyer ( @@ -83,7 +83,7 @@ generateDamage = sample' (arbitrary :: Gen Damage) applyDamage :: [Damage] -> Repo -> IO () applyDamage ds r = do contents <- sort . filter (not . skipped) - <$> dirContentsRecursive (localGitDir r) + <$> dirContentsRecursive (fromRawFilePath (localGitDir r)) forM_ ds $ \d -> do let withfile s a = do let f = selectFile contents s diff --git a/Git/DiffTreeItem.hs b/Git/DiffTreeItem.hs index 859f590..ffda2e8 100644 --- a/Git/DiffTreeItem.hs +++ b/Git/DiffTreeItem.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.DiffTreeItem ( diff --git a/Git/FilePath.hs b/Git/FilePath.hs index ffa3331..66a0159 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,12 +5,14 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Git.FilePath ( TopFilePath, @@ -29,30 +31,39 @@ module Git.FilePath ( import Common import Git -import qualified System.FilePath.Posix +import qualified System.FilePath.ByteString as P +import qualified System.FilePath.Posix.ByteString +import GHC.Generics +import Control.DeepSeq +import qualified Data.ByteString as S -{- A FilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show, Eq, Ord) +{- A RawFilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } + deriving (Show, Eq, Ord, Generic) + +instance NFData TopFilePath {- A file in a branch or other treeish. -} 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) <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath +fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file +toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath . toRawFilePath + <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) -{- The input FilePath must already be relative to the top of the git +{- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: FilePath -> TopFilePath +asTopFilePath :: RawFilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -62,25 +73,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 = P.isAbsolute p || + System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) diff --git a/Git/Filename.hs b/Git/Filename.hs index 355e75f..010e5ba 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -3,7 +3,7 @@ - - Copyright 2010, 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Filename where @@ -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 ascii + nohigh = filter isAscii + -- 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') diff --git a/Git/Fsck.hs b/Git/Fsck.hs index a716b56..6f33e11 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} @@ -22,10 +22,11 @@ import Git import Git.Command import Git.Sha import Utility.Batch -import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async +import qualified Data.Semigroup as Sem +import Prelude data FsckResults = FsckFoundMissing @@ -44,15 +45,21 @@ type MissingObjects = S.Set Sha type Truncated = Bool +appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput +appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) = + FsckOutput (S.union s1 s2) (t1 || t2) +appendFsckOutput (FsckOutput s t) _ = FsckOutput s t +appendFsckOutput _ (FsckOutput s t) = FsckOutput s t +appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput +appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning +appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning +appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + +instance Sem.Semigroup FsckOutput where + (<>) = appendFsckOutput + instance Monoid FsckOutput where mempty = NoFsckOutput - mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2) - mappend (FsckOutput s t) _ = FsckOutput s t - mappend _ (FsckOutput s t) = FsckOutput s t - mappend NoFsckOutput NoFsckOutput = NoFsckOutput - mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning - mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning - mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning {- Runs fsck to find some of the broken objects in the repository. - May not find all broken objects, if fsck fails on bad data in some of @@ -65,9 +72,7 @@ instance Monoid FsckOutput where -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do - supportsNoDangling <- (>= Git.Version.normalize "1.7.10") - <$> Git.Version.installed - let (command, params) = ("git", fsckParams supportsNoDangling r) + let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params) else return (command, params) @@ -78,8 +83,8 @@ findBroken batchmode r = do , std_err = CreatePipe } (o1, o2) <- concurrently - (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p)) - (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) + (parseFsckOutput maxobjs r (stdoutHandle p)) + (parseFsckOutput maxobjs r (stderrHandle p)) fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated @@ -112,15 +117,15 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r supportsNoDangling h = do +parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput +parseFsckOutput maxobjs r h = do ls <- lines <$> hGetContents h if null ls then return NoFsckOutput else if all ("duplicateEntries" `isInfixOf`) ls then return AllDuplicateEntriesWarning else do - let shas = findShas supportsNoDangling ls + let shas = findShas ls let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated @@ -133,18 +138,14 @@ isMissing s r = either (const True) (const False) <$> tryIO dump , Param (fromRef s) ] r -findShas :: Bool -> [String] -> [Sha] -findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted +findShas :: [String] -> [Sha] +findShas = catMaybes . map extractSha . concat . map words . filter wanted where - wanted l - | supportsNoDangling = True - | otherwise = not ("dangling " `isPrefixOf` l) - -fsckParams :: Bool -> Repo -> [CommandParam] -fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes - [ Just "fsck" - , if supportsNoDangling - then Just "--no-dangling" - else Nothing - , Just "--no-reflogs" + wanted l = not ("dangling " `isPrefixOf` l) + +fsckParams :: Repo -> [CommandParam] +fsckParams = gitCommandLine $ map Param + [ "fsck" + , "--no-dangling" + , "--no-reflogs" ] diff --git a/Git/HashObject.hs b/Git/HashObject.hs new file mode 100644 index 0000000..3787c9c --- /dev/null +++ b/Git/HashObject.hs @@ -0,0 +1,76 @@ +{- git hash-object interface + - + - Copyright 2011-2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.HashObject where + +import Common +import Git +import Git.Sha +import Git.Command +import Git.Types +import qualified Utility.CoProcess as CoProcess +import Utility.Tmp + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder + +type HashObjectHandle = CoProcess.CoProcessHandle + +hashObjectStart :: Bool -> Repo -> IO HashObjectHandle +hashObjectStart writeobject = gitCoProcessStart True $ catMaybes + [ Just (Param "hash-object") + , if writeobject then Just (Param "-w") else Nothing + , Just (Param "--stdin-paths") + , Just (Param "--no-filters") + ] + +hashObjectStop :: HashObjectHandle -> IO () +hashObjectStop = CoProcess.stop + +{- Injects a file into git, returning the Sha of the object. -} +hashFile :: HashObjectHandle -> FilePath -> IO Sha +hashFile h file = CoProcess.query h send receive + where + send to = hPutStrLn to =<< absPath file + receive from = getSha "hash-object" $ hGetLine from + +class HashableBlob t where + hashableBlobToHandle :: Handle -> t -> IO () + +instance HashableBlob L.ByteString where + hashableBlobToHandle = L.hPut + +instance HashableBlob S.ByteString where + hashableBlobToHandle = S.hPut + +instance HashableBlob Builder where + hashableBlobToHandle = hPutBuilder + +{- Injects a blob into git. Unfortunately, the current git-hash-object + - interface does not allow batch hashing without using temp files. -} +hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha +hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do + hashableBlobToHandle tmph b + hClose tmph + hashFile h tmp + +{- Injects some content into git, returning its Sha. + - + - Avoids using a tmp file, but runs a new hash-object command each + - time called. -} +hashObject :: ObjectType -> String -> Repo -> IO Sha +hashObject objtype content = hashObject' objtype (flip hPutStr content) + +hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha +hashObject' objtype writer repo = getSha subcmd $ + pipeWriteRead (map Param params) (Just writer) repo + where + subcmd = "hash-object" + params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"] diff --git a/Git/Index.hs b/Git/Index.hs index 85ea480..afd29c2 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -1,8 +1,8 @@ {- git index file stuff - - - Copyright 2011 Joey Hess + - Copyright 2011-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Index where @@ -10,6 +10,7 @@ module Git.Index where import Common import Git import Utility.Env +import Utility.Env.Set indexEnv :: String indexEnv = "GIT_INDEX_FILE" @@ -46,25 +47,14 @@ override index _r = do reset (Just v) = setEnv indexEnv v True reset _ = unsetEnv var +{- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath -indexFile r = localGitDir r "index" +indexFile r = fromRawFilePath (localGitDir r) "index" -{- Git locks the index by creating this file. -} -indexFileLock :: Repo -> FilePath -indexFileLock r = indexFile r ++ ".lock" +{- The index file git will currently use, checking GIT_INDEX_FILE. -} +currentIndexFile :: Repo -> IO FilePath +currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv -{- When the pre-commit hook is run, and git commit has been run with - - a file or files specified to commit, rather than committing the staged - - index, git provides the pre-commit hook with a "false index file". - - - - Changes made to this index will influence the commit, but won't - - affect the real index file. - - - - This detects when we're in this situation, using a heuristic, which - - might be broken by changes to git. Any use of this should have a test - - case to make sure it works. - -} -haveFalseIndex :: IO Bool -haveFalseIndex = maybe (False) check <$> getEnv indexEnv - where - check f = "next-index" `isPrefixOf` takeFileName f +{- Git locks the index by creating this file. -} +indexFileLock :: FilePath -> FilePath +indexFileLock f = f ++ ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index f945838..5534307 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,13 +1,15 @@ {- git ls-files interface - - - Copyright 2010,2012 Joey Hess + - Copyright 2010-2018 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.LsFiles ( inRepo, + inRepoOrBranch, notInRepo, + notInRepoIncludingEmptyDirectories, allFiles, deleted, modified, @@ -32,69 +34,89 @@ import Git.Sha import Numeric import System.Posix.Types +import qualified Data.ByteString.Lazy as L -{- Scans for files that are checked into git at the specified locations. -} -inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -inRepo l = pipeNullSplit $ - Param "ls-files" : - Param "--cached" : - Param "-z" : - Param "--" : - map File l +{- Scans for files that are checked into git's index at the specified locations. -} +inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo = inRepo' [] + +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 -> [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 include_ignored l repo = pipeNullSplit params repo +notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo = notInRepo' [] + +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 = [] | otherwise = [Param "--exclude-standard"] +{- Scans for files at the specified locations that are not checked into + - git. Empty directories are included in the result. -} +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" : @@ -103,69 +125,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) + top <- absPath (fromRawFilePath (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" @@ -173,7 +195,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. -} @@ -183,10 +205,10 @@ data Conflicting v = Conflicting } deriving (Show) data Unmerged = Unmerged - { unmergedFile :: FilePath - , unmergedBlobType :: Conflicting BlobType + { unmergedFile :: RawFilePath + , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha - } deriving (Show) + } {- Returns a list of the files in the specified locations that have - unresolved merge conflicts. @@ -198,38 +220,38 @@ 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 - , iblobtype :: Maybe BlobType + , ifile :: RawFilePath + , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha - } deriving (Show) + } parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s | null file = Nothing | otherwise = case words metadata of - (rawblobtype:rawsha:rawstage:_) -> do + (rawtreeitemtype:rawsha:rawstage:_) -> do stage <- readish rawstage :: Maybe Int if stage /= 2 && stage /= 3 then Nothing else do - blobtype <- readBlobType rawblobtype + treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) sha <- extractSha rawsha - return $ InternalUnmerged (stage == 2) file - (Just blobtype) (Just sha) + return $ InternalUnmerged (stage == 2) (toRawFilePath file) + (Just treeitemtype) (Just sha) _ -> Nothing where (metadata, file) = separate (== '\t') s @@ -239,12 +261,12 @@ reduceUnmerged c [] = c reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest where (rest, sibi) = findsib i is - (blobtypeA, blobtypeB, shaA, shaB) - | isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi) - | otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i) + (treeitemtypeA, treeitemtypeB, shaA, shaB) + | isus i = (itreeitemtype i, itreeitemtype sibi, isha i, isha sibi) + | otherwise = (itreeitemtype sibi, itreeitemtype i, isha sibi, isha i) new = Unmerged { unmergedFile = ifile i - , unmergedBlobType = Conflicting blobtypeA blobtypeB + , unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB , unmergedSha = Conflicting shaA shaB } findsib templatei [] = ([], removed templatei) @@ -253,6 +275,6 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest | otherwise = (l:ls, removed templatei) removed templatei = templatei { isus = not (isus templatei) - , iblobtype = Nothing + , itreeitemtype = Nothing , isha = Nothing } diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 225f2ce..a3d8383 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,19 +1,21 @@ {- git ls-tree interface - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} module Git.LsTree ( TreeItem(..), + LsTreeMode(..), lsTree, lsTree', lsTreeParams, lsTreeFiles, parseLsTree, + formatLsTree, ) where import Common @@ -22,42 +24,52 @@ 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 -{- Lists the complete contents of a tree, recursing into sub-trees, - - with lazy output. -} -lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool) +data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive + +{- Lists the contents of a tree, with lazy output. -} +lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree = lsTree' [] -lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool) -lsTree' ps t repo = do - (l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo - return (map parseLsTree l, cleanup) +lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) +lsTree' ps lsmode t repo = do + (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo + return (rights (map parseLsTree l), cleanup) -lsTreeParams :: Ref -> [CommandParam] -> [CommandParam] -lsTreeParams r ps = +lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] +lsTreeParams lsmode r ps = [ Param "ls-tree" , Param "--full-tree" , Param "-z" - , Param "-r" - ] ++ ps ++ + ] ++ recursiveparams ++ ps ++ [ Param "--" , File $ fromRef r ] + where + recursiveparams = case lsmode of + LsTreeRecursive -> [ Param "-r" ] + LsTreeNonRecursive -> [] {- 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" @@ -67,21 +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 . Git.Filename.decode <$> A.takeByteString) + +{- Inverse of parseLsTree -} +formatLsTree :: TreeItem -> String +formatLsTree ti = unwords + [ showOct (mode ti) "" + , decodeBS (typeobj ti) + , fromRef (sha ti) + , fromRawFilePath (getTopFilePath (file ti)) + ] diff --git a/Git/Objects.hs b/Git/Objects.hs index bda220b..c9ede4d 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Objects where @@ -12,7 +12,7 @@ import Git import Git.Sha objectsDir :: Repo -> FilePath -objectsDir r = localGitDir r "objects" +objectsDir r = fromRawFilePath (localGitDir r) "objects" packDir :: Repo -> FilePath packDir r = objectsDir r "pack" diff --git a/Git/Ref.hs b/Git/Ref.hs index 1986db6..621e328 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,10 +1,12 @@ {- git ref stuff - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Ref where import Common @@ -13,13 +15,14 @@ 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" headFile :: Repo -> FilePath -headFile r = localGitDir r "HEAD" +headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) @@ -33,11 +36,18 @@ describe = fromRef . base - Converts such a fully qualified ref into a base ref - (eg: master or origin/master). -} base :: Ref -> Ref -base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef +base = removeBase "refs/heads/" . removeBase "refs/remotes/" + +{- Removes a directory such as "refs/heads/master" from a + - fully qualified ref. Any ref not starting with it is left as-is. -} +removeBase :: String -> Ref -> Ref +removeBase dir (Ref r) + | prefix `isPrefixOf` r = Ref (drop (length prefix) r) + | otherwise = Ref r where - remove prefix s - | prefix `isPrefixOf` s = drop (length prefix) s - | otherwise = s + prefix = case end dir of + ['/'] -> dir + _ -> dir ++ "/" {- Given a directory such as "refs/remotes/origin", and a ref such as - refs/heads/master, yields a version of that ref under the directory, @@ -55,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 @@ -64,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. -} @@ -75,24 +85,29 @@ exists ref = runBool {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} file :: Ref -> Repo -> FilePath -file ref repo = localGitDir repo fromRef ref +file ref repo = fromRawFilePath (localGitDir repo) fromRef ref {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} headExists :: Repo -> IO Bool headExists repo = do - ls <- 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) sha branch repo = process <$> showref repo where - showref = pipeReadStrict [Param "show-ref", - Param "--hash", -- get the hash - Param $ fromRef branch] - process [] = Nothing - process s = Just $ Ref $ firstLine s + showref = pipeReadStrict + [ Param "show-ref" + , Param "--hash" -- get the hash + , Param $ fromRef branch + ] + process s + | S.null s = Nothing + | otherwise = Just $ Ref $ decodeBS' $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef @@ -107,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 @@ -134,10 +149,13 @@ delete oldvalue ref = run , Param $ fromRef oldvalue ] -{- Gets the sha of the tree a ref uses. -} +{- Gets the sha of the tree a ref uses. + - + - The ref may be something like a branch name, and it could contain + - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha <$$> pipeReadStrict - [ Param "rev-parse", Param ref' ] +tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict + [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] where ref' = if ":" `isInfixOf` ref then ref diff --git a/Git/RefLog.hs b/Git/RefLog.hs index 57f35e9..7ba8713 100644 --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.RefLog where @@ -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" diff --git a/Git/Remote.hs b/Git/Remote.hs index f6eaf93..69d6b52 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -2,10 +2,11 @@ - - Copyright 2012 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Remote where @@ -15,11 +16,22 @@ 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 :: 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 :: 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. - - There seems to be no formal definition of this in the git source, @@ -43,6 +55,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of legal c = isAlphaNum c data RemoteLocation = RemoteUrl String | RemotePath FilePath + deriving (Eq) remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True @@ -67,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 @@ -104,5 +117,5 @@ parseRemoteLocation s repo = ret $ calcloc s -- git on Windows will write a path to .git/config with "drive:", -- which is not to be confused with a "host:" dosstyle = hasDrive - dospath = fromInternalGitPath + dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath #endif diff --git a/Git/Repair.hs b/Git/Repair.hs index 8e43248..66e6811 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -2,7 +2,7 @@ - - Copyright 2013-2014 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Repair ( @@ -11,7 +11,6 @@ module Git.Repair ( removeBadBranches, successfulRepair, cleanCorruptObjects, - retrieveMissingObjects, resetLocalBranches, checkIndex, checkIndexFast, @@ -36,7 +35,7 @@ import qualified Git.Ref as Ref import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch -import Utility.Tmp +import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode import Utility.Tuple @@ -102,10 +101,11 @@ retrieveMissingObjects missing referencerepo r unlessM (boolSystem "git" [Param "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromAbsPath tmpdir - stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing + rs <- Construct.fromRemotes r + stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) then return stillmissing - else pullremotes tmpr (remotes r) fetchallrefs stillmissing + else pullremotes tmpr rs fetchallrefs stillmissing where pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of Nothing -> return stillmissing @@ -227,7 +227,7 @@ badBranches missing r = filterM isbad =<< getAllRefs r - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (localGitDir r "refs") +getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do @@ -245,13 +245,13 @@ explodePackedRefsFile r = do nukeFile f where makeref (sha, ref) = do - let dest = localGitDir r fromRef ref + let dest = fromRawFilePath (localGitDir r) fromRef ref createDirectoryIfMissing True (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) packedRefsFile :: Repo -> FilePath -packedRefsFile r = localGitDir r "packed-refs" +packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -263,7 +263,7 @@ parsePacked l = case words l of {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ localGitDir r fromRef b +nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -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 @@ -341,8 +341,8 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do - (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r - let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls if any (`S.member` missing) objshas then do void cleanup @@ -370,7 +370,7 @@ checkIndexFast r = do length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (localGitDir r "index") +missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) @@ -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 toBlobType mode of + reinject (file, Just sha, Just mode) = case toTreeItemType mode of Nothing -> return Nothing - Just blobtype -> Just <$> - UpdateIndex.stageFile sha blobtype file r + Just treeitemtype -> Just <$> + UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) @@ -446,7 +446,7 @@ preRepair g = do let f = indexFile g void $ tryIO $ allowWrite f where - headfile = localGitDir g "HEAD" + headfile = fromRawFilePath (localGitDir g) "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) {- Put it all together. -} diff --git a/Git/Sha.hs b/Git/Sha.hs index b802c85..cc33cac 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -2,7 +2,7 @@ - - Copyright 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Sha where diff --git a/Git/Types.hs b/Git/Types.hs index 327c1d7..9c2754a 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,16 +1,23 @@ {- git data types - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - 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. - @@ -23,19 +30,19 @@ import Utility.SafeCommand - else known about it. -} data RepoLocation - = Local { gitdir :: FilePath, worktree :: Maybe FilePath } - | LocalUnknown FilePath + = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } + | LocalUnknown RawFilePath | Url URI | Unknown deriving (Show, Eq, Ord) 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] - , remotes :: [Repo] - -- remoteName holds the name used for this repo in remotes + , 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 -- alternate environment to use when running git commands , gitEnv :: Maybe [(String, String)] @@ -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,45 +98,48 @@ 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 -{- Types of blobs. -} -data BlobType = FileBlob | ExecutableBlob | SymlinkBlob - deriving (Eq) - -{- Git uses magic numbers to denote the type of a blob. -} -instance Show BlobType where - show FileBlob = "100644" - show ExecutableBlob = "100755" - show SymlinkBlob = "120000" - -readBlobType :: String -> Maybe BlobType -readBlobType "100644" = Just FileBlob -readBlobType "100755" = Just ExecutableBlob -readBlobType "120000" = Just SymlinkBlob -readBlobType _ = Nothing - -toBlobType :: FileMode -> Maybe BlobType -toBlobType 0o100644 = Just FileBlob -toBlobType 0o100755 = Just ExecutableBlob -toBlobType 0o120000 = Just SymlinkBlob -toBlobType _ = Nothing - -fromBlobType :: BlobType -> FileMode -fromBlobType FileBlob = 0o100644 -fromBlobType ExecutableBlob = 0o100755 -fromBlobType SymlinkBlob = 0o120000 +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, Show) + +{- Git uses magic numbers to denote the type of a tree item. -} +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 -> S.ByteString +fmtTreeItemType TreeFile = "100644" +fmtTreeItemType TreeExecutable = "100755" +fmtTreeItemType TreeSymlink = "120000" +fmtTreeItemType TreeSubmodule = "160000" + +toTreeItemType :: FileMode -> Maybe TreeItemType +toTreeItemType 0o100644 = Just TreeFile +toTreeItemType 0o100755 = Just TreeExecutable +toTreeItemType 0o120000 = Just TreeSymlink +toTreeItemType 0o160000 = Just TreeSubmodule +toTreeItemType _ = Nothing + +fromTreeItemType :: TreeItemType -> FileMode +fromTreeItemType TreeFile = 0o100644 +fromTreeItemType TreeExecutable = 0o100755 +fromTreeItemType TreeSymlink = 0o120000 +fromTreeItemType TreeSubmodule = 0o160000 data Commit = Commit { commitTree :: Sha diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 7fdc945..9f07cf5 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,11 +1,11 @@ {- git-update-index library - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Git.UpdateIndex ( Streamer, @@ -21,6 +21,7 @@ module Git.UpdateIndex ( unstageFile, stageSymlink, stageDiffTreeItem, + refreshIndex, ) where import Common @@ -31,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. -} @@ -48,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 @@ -83,38 +86,66 @@ 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 -> BlobType -> TopFilePath -> String -updateIndexLine sha filetype file = - show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file - -stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer -stageFile sha filetype file repo = do - p <- toTopFilePath file repo - return $ pureStreamer $ updateIndexLine sha filetype p +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 + p <- toTopFilePath (toRawFilePath file) repo + return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo 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 stageSymlink file sha repo = do !line <- updateIndexLine <$> pure sha - <*> pure SymlinkBlob - <*> toTopFilePath file repo + <*> pure TreeSymlink + <*> toTopFilePath (toRawFilePath file) repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer -stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of +stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of Nothing -> unstageFile' (Diff.file d) Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath + +{- Refreshes the index, by checking file stat information. -} +refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool +refreshIndex repo feeder = do + (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) + { std_in = CreatePipe } + feeder $ \f -> do + hPutStr h f + hPutStr h "\0" + hFlush h + hClose h + checkSuccessProcess p + where + params = + [ Param "update-index" + , Param "-q" + , Param "--refresh" + , Param "-z" + , Param "--stdin" + ] diff --git a/Git/Url.hs b/Git/Url.hs index fa7d200..8430655 100644 --- a/Git/Url.hs +++ b/Git/Url.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2011 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} module Git.Url ( @@ -11,9 +11,10 @@ module Git.Url ( port, hostuser, authority, + path, ) where -import Network.URI hiding (scheme, authority) +import Network.URI hiding (scheme, authority, path) import Common import Git.Types @@ -66,6 +67,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ repo = notUrl repo +{- Path part of an URL repo. -} +path :: Repo -> FilePath +path Repo { location = Url u } = uriPath u +path repo = notUrl repo + notUrl :: Repo -> a notUrl repo = error $ "acting on local git repo " ++ repoDescribe repo ++ " not supported" diff --git a/Git/Version.hs b/Git/Version.hs index 19ff945..5ecaca0 100644 --- a/Git/Version.hs +++ b/Git/Version.hs @@ -2,7 +2,7 @@ - - Copyright 2011, 2013 Joey Hess - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# OPTIONS_GHC -fno-warn-tabs #-} -- cgit v1.2.3