summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
Diffstat (limited to 'Git')
-rw-r--r--Git/Branch.hs153
-rw-r--r--Git/BuildVersion.hs21
-rw-r--r--Git/CatFile.hs108
-rw-r--r--Git/Command.hs138
-rw-r--r--Git/Config.hs198
-rw-r--r--Git/Construct.hs236
-rw-r--r--Git/CurrentRepo.hs67
-rw-r--r--Git/Destroyer.hs126
-rw-r--r--Git/FilePath.hs64
-rw-r--r--Git/Filename.hs28
-rw-r--r--Git/Fsck.hs81
-rw-r--r--Git/Index.hs32
-rw-r--r--Git/LsFiles.hs214
-rw-r--r--Git/LsTree.hs65
-rw-r--r--Git/Objects.hs35
-rw-r--r--Git/Ref.hs139
-rw-r--r--Git/RefLog.hs22
-rw-r--r--Git/Remote.hs115
-rw-r--r--Git/Repair.hs548
-rw-r--r--Git/Sha.hs39
-rw-r--r--Git/Types.hs95
-rw-r--r--Git/UpdateIndex.hs86
-rw-r--r--Git/Url.hs71
-rw-r--r--Git/Version.hs43
24 files changed, 2724 insertions, 0 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs
new file mode 100644
index 0000000..405fa10
--- /dev/null
+++ b/Git/Branch.hs
@@ -0,0 +1,153 @@
+{- git branch stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Git.Branch where
+
+import Common
+import Git
+import Git.Sha
+import Git.Command
+import qualified Git.Ref
+
+{- 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
+ - to double-check.
+ -}
+current :: Repo -> IO (Maybe Git.Ref)
+current r = do
+ v <- currentUnsafe r
+ case v of
+ Nothing -> return Nothing
+ Just branch ->
+ ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)
+ ( return Nothing
+ , return v
+ )
+
+{- The current branch, which may not really exist yet. -}
+currentUnsafe :: Repo -> IO (Maybe Git.Ref)
+currentUnsafe r = parse . firstLine
+ <$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
+ where
+ parse l
+ | null l = Nothing
+ | otherwise = Just $ Git.Ref l
+
+{- Checks if the second branch has any commits not present on the first
+ - branch. -}
+changed :: Branch -> Branch -> Repo -> IO Bool
+changed origbranch newbranch repo
+ | origbranch == newbranch = return False
+ | otherwise = not . null <$> diffs
+ where
+ diffs = pipeReadStrict
+ [ Param "log"
+ , Param (show origbranch ++ ".." ++ show newbranch)
+ , Params "--oneline -n1"
+ ] repo
+
+{- Given a set of refs that are all known to have commits not
+ - on the branch, tries to update the branch by a fast-forward.
+ -
+ - In order for that to be possible, one of the refs must contain
+ - every commit present in all the other refs.
+ -}
+fastForward :: Branch -> [Ref] -> Repo -> IO Bool
+fastForward _ [] _ = return True
+fastForward branch (first:rest) repo =
+ -- First, check that the branch does not contain any
+ -- new commits that are not in the first ref. If it does,
+ -- cannot fast-forward.
+ ifM (changed first branch repo)
+ ( no_ff
+ , maybe no_ff do_ff =<< findbest first rest
+ )
+ where
+ no_ff = return False
+ do_ff to = do
+ run [Param "update-ref", Param $ show branch, Param $ show to] repo
+ return True
+ findbest c [] = return $ Just c
+ findbest c (r:rs)
+ | c == r = findbest c rs
+ | otherwise = do
+ better <- changed c r repo
+ worse <- changed r c repo
+ case (better, worse) of
+ (True, True) -> return Nothing -- divergent fail
+ (True, False) -> findbest r rs -- better
+ (False, True) -> findbest c rs -- worse
+ (False, False) -> findbest c rs -- same
+
+{- Commits the index into the specified branch (or other ref),
+ - with the specified parent refs, and returns the committed sha.
+ -
+ - Without allowempy set, avoids making a commit if there is exactly
+ - one parent, and it has the same tree that would be committed.
+ -
+ - Unlike git-commit, does not run any hooks, or examine the work tree
+ - in any way.
+ -}
+commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
+commit allowempty message branch parentrefs repo = do
+ tree <- getSha "write-tree" $
+ pipeReadStrict [Param "write-tree"] repo
+ ifM (cancommit tree)
+ ( do
+ sha <- getSha "commit-tree" $ pipeWriteRead
+ (map Param $ ["commit-tree", show tree] ++ ps)
+ (Just $ flip hPutStr message) repo
+ update branch sha repo
+ return $ Just sha
+ , return Nothing
+ )
+ where
+ ps = concatMap (\r -> ["-p", show r]) parentrefs
+ cancommit tree
+ | allowempty = return True
+ | otherwise = case parentrefs of
+ [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
+ _ -> return True
+
+commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha
+commitAlways message branch parentrefs repo = fromJust
+ <$> commit True message branch parentrefs repo
+
+{- A leading + makes git-push force pushing a branch. -}
+forcePush :: String -> String
+forcePush b = "+" ++ b
+
+{- Updates a branch (or other ref) to a new Sha. -}
+update :: Branch -> Sha -> Repo -> IO ()
+update branch sha = run
+ [ Param "update-ref"
+ , Param $ show branch
+ , Param $ show sha
+ ]
+
+{- Checks out a branch, creating it if necessary. -}
+checkout :: Branch -> Repo -> IO ()
+checkout branch = run
+ [ Param "checkout"
+ , Param "-q"
+ , Param "-B"
+ , Param $ show $ Git.Ref.base branch
+ ]
+
+{- Removes a branch. -}
+delete :: Branch -> Repo -> IO ()
+delete branch = run
+ [ Param "branch"
+ , Param "-q"
+ , Param "-D"
+ , Param $ show $ Git.Ref.base branch
+ ]
diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs
new file mode 100644
index 0000000..832ee8a
--- /dev/null
+++ b/Git/BuildVersion.hs
@@ -0,0 +1,21 @@
+{- git build version
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.BuildVersion where
+
+import Git.Version
+import qualified Build.SysConfig
+
+{- Using the version it was configured for avoids running git to check its
+ - version, at the cost that upgrading git won't be noticed.
+ - This is only acceptable because it's rare that git's version influences
+ - code's behavior. -}
+buildVersion :: GitVersion
+buildVersion = normalize Build.SysConfig.gitversion
+
+older :: String -> Bool
+older n = buildVersion < normalize n
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
new file mode 100644
index 0000000..aee6bd1
--- /dev/null
+++ b/Git/CatFile.hs
@@ -0,0 +1,108 @@
+{- git cat-file interface
+ -
+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.CatFile (
+ CatFileHandle,
+ catFileStart,
+ catFileStart',
+ catFileStop,
+ catFile,
+ catTree,
+ catObject,
+ catObjectDetails,
+) where
+
+import System.IO
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Data.Tuple.Utils
+import Numeric
+import System.Posix.Types
+
+import Common
+import Git
+import Git.Sha
+import Git.Command
+import Git.Types
+import Git.FilePath
+import qualified Utility.CoProcess as CoProcess
+
+data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo
+
+catFileStart :: Repo -> IO CatFileHandle
+catFileStart = catFileStart' True
+
+catFileStart' :: Bool -> Repo -> IO CatFileHandle
+catFileStart' restartable repo = do
+ coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable
+ [ Param "cat-file"
+ , Param "--batch"
+ ] repo
+ return $ CatFileHandle coprocess repo
+
+catFileStop :: CatFileHandle -> IO ()
+catFileStop (CatFileHandle p _) = CoProcess.stop p
+
+{- Reads a file from a specified branch. -}
+catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
+catFile h branch file = catObject h $ Ref $
+ show branch ++ ":" ++ toInternalGitPath file
+
+{- Uses a running git cat-file read the content of an object.
+ - Objects that do not exist will have "" returned. -}
+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 (CatFileHandle hdl _) object = CoProcess.query hdl send receive
+ where
+ query = show object
+ send to = hPutStrLn to query
+ receive from = do
+ header <- hGetLine from
+ case words header of
+ [sha, objtype, size]
+ | length sha == shaSize ->
+ case (readObjectType objtype, reads size) of
+ (Just t, [(bytes, "")]) -> readcontent t bytes from sha
+ _ -> dne
+ | otherwise -> dne
+ _
+ | header == show object ++ " missing" -> dne
+ | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
+ readcontent objtype bytes from sha = do
+ content <- S.hGet from bytes
+ eatchar '\n' from
+ return $ Just (L.fromChunks [content], Ref sha, objtype)
+ dne = return Nothing
+ eatchar expected from = do
+ c <- hGetChar from
+ when (c /= expected) $
+ error $ "missing " ++ (show expected) ++ " from git cat-file"
+
+{- 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
+ where
+ go (Just (b, _, TreeObject)) = parsetree [] b
+ go _ = []
+
+ parsetree c b = case L.break (== 0) b of
+ (modefile, rest)
+ | L.null modefile -> c
+ | otherwise -> parsetree
+ (parsemodefile modefile:c)
+ (dropsha rest)
+
+ -- these 20 bytes after the NUL hold the file's sha
+ -- TODO: convert from raw form to regular sha
+ dropsha = L.drop 21
+
+ parsemodefile b =
+ let (modestr, file) = separate (== ' ') (encodeW8 $ L.unpack b)
+ in (file, readmode modestr)
+ readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct
diff --git a/Git/Command.hs b/Git/Command.hs
new file mode 100644
index 0000000..adcc53b
--- /dev/null
+++ b/Git/Command.hs
@@ -0,0 +1,138 @@
+{- running git commands
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Git.Command where
+
+import System.Process (std_out, env)
+
+import Common
+import Git
+import Git.Types
+import qualified Utility.CoProcess as CoProcess
+#ifdef mingw32_HOST_OS
+import Git.FilePath
+#endif
+
+{- Constructs a git command line operating on the specified repo. -}
+gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
+gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
+ setdir : settree ++ gitGlobalOpts r ++ params
+ where
+ setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)
+ settree = case worktree l of
+ Nothing -> []
+ Just t -> [Param $ "--work-tree=" ++ gitpath t]
+#ifdef mingw32_HOST_OS
+ -- despite running on windows, msysgit wants a unix-formatted path
+ gitpath s
+ | isAbsolute s = "/" ++ dropDrive (toInternalGitPath s)
+ | otherwise = s
+#else
+ gitpath = id
+#endif
+gitCommandLine _ repo = assertLocal repo $ error "internal"
+
+{- Runs git in the specified repo. -}
+runBool :: [CommandParam] -> Repo -> IO Bool
+runBool params repo = assertLocal repo $
+ boolSystemEnv "git"
+ (gitCommandLine params repo)
+ (gitEnv repo)
+
+{- Runs git in the specified repo, throwing an error if it fails. -}
+run :: [CommandParam] -> Repo -> IO ()
+run params repo = assertLocal repo $
+ unlessM (runBool params repo) $
+ error $ "git " ++ show params ++ " failed"
+
+{- Runs git and forces it to be quiet, throwing an error if it fails. -}
+runQuiet :: [CommandParam] -> Repo -> IO ()
+runQuiet params repo = withQuietOutput createProcessSuccess $
+ (proc "git" $ toCommand $ gitCommandLine (params) repo)
+ { env = gitEnv repo }
+
+{- 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
+ - return True if it succeeded. Failure to wait will result in zombies.
+ -}
+pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)
+pipeReadLazy params repo = assertLocal repo $ do
+ (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }
+ fileEncoding h
+ c <- hGetContents h
+ return (c, checkSuccessProcess pid)
+ where
+ p = gitCreateProcess params repo
+
+{- Runs a git command, and returns its output, strictly.
+ -
+ - Nonzero exit status is ignored.
+ -}
+pipeReadStrict :: [CommandParam] -> Repo -> IO String
+pipeReadStrict params repo = assertLocal repo $
+ withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
+ fileEncoding h
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+ where
+ p = gitCreateProcess params repo
+
+{- Runs a git command, feeding it an input, and returning its output,
+ - which is expected to be fairly small, since it's all read into memory
+ - strictly. -}
+pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String
+pipeWriteRead params writer repo = assertLocal repo $
+ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo)
+ (gitEnv repo) writer (Just adjusthandle)
+ where
+ adjusthandle h = do
+ fileEncoding h
+ hSetNewlineMode h noNewlineTranslation
+
+{- 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
+
+{- 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 params repo = do
+ (s, cleanup) <- pipeReadLazy params repo
+ return (filter (not . null) $ split sep s, cleanup)
+ where
+ sep = "\0"
+
+pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]
+pipeNullSplitStrict params repo = do
+ s <- pipeReadStrict params repo
+ return $ filter (not . null) $ split sep s
+ where
+ sep = "\0"
+
+pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
+pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
+
+{- Doesn't run the cleanup action. A zombie results. -}
+leaveZombie :: (a, IO Bool) -> a
+leaveZombie = fst
+
+{- Runs a git command as a coprocess. -}
+gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
+gitCoProcessStart restartable params repo = CoProcess.start restartable "git"
+ (toCommand $ gitCommandLine params repo)
+ (gitEnv repo)
+
+gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess
+gitCreateProcess params repo =
+ (proc "git" $ toCommand $ gitCommandLine params repo)
+ { env = gitEnv repo }
diff --git a/Git/Config.hs b/Git/Config.hs
new file mode 100644
index 0000000..b5c1be0
--- /dev/null
+++ b/Git/Config.hs
@@ -0,0 +1,198 @@
+{- git repository configuration handling
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Config where
+
+import qualified Data.Map as M
+import Data.Char
+import System.Process (cwd, env)
+import Control.Exception.Extensible
+
+import Common
+import Git
+import Git.Types
+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 list with each line of a multiline config setting. -}
+getList :: String -> Repo -> [String]
+getList key repo = M.findWithDefault [] key (fullconfig repo)
+
+{- Returns a single git config setting, if set. -}
+getMaybe :: String -> Repo -> Maybe String
+getMaybe key repo = M.lookup key (config repo)
+
+{- Runs git config and populates a repo with its config.
+ - Avoids re-reading config when run repeatedly. -}
+read :: Repo -> IO Repo
+read repo@(Repo { config = c })
+ | c == M.empty = read' repo
+ | otherwise = return repo
+
+{- Reads config even if it was read before. -}
+reRead :: Repo -> IO Repo
+reRead r = read' $ r
+ { config = M.empty
+ , fullconfig = M.empty
+ }
+
+{- Cannot use pipeRead because it relies on the config having been already
+ - read. Instead, chdir to the repo and run git config.
+ -}
+read' :: Repo -> IO Repo
+read' repo = go repo
+ where
+ go Repo { location = Local { gitdir = d } } = git_config d
+ go Repo { location = LocalUnknown d } = git_config d
+ go _ = assertLocal repo $ error "internal"
+ git_config d = withHandle StdoutHandle createProcessSuccess p $
+ hRead repo
+ where
+ params = ["config", "--null", "--list"]
+ p = (proc "git" params)
+ { cwd = Just d
+ , env = gitEnv repo
+ }
+
+{- Gets the global git config, returning a dummy Repo containing it. -}
+global :: IO (Maybe Repo)
+global = do
+ home <- myHomeDir
+ ifM (doesFileExist $ home </> ".gitconfig")
+ ( do
+ repo <- Git.Construct.fromUnknown
+ repo' <- withHandle StdoutHandle createProcessSuccess p $
+ hRead repo
+ return $ Just repo'
+ , return Nothing
+ )
+ where
+ params = ["config", "--null", "--list", "--global"]
+ p = (proc "git" params)
+
+{- Reads git config from a handle and populates a repo with it. -}
+hRead :: Repo -> Handle -> IO Repo
+hRead repo h = do
+ -- We use the FileSystemEncoding when reading from git-config,
+ -- because it can contain arbitrary filepaths (and other strings)
+ -- in any encoding.
+ fileEncoding h
+ val <- hGetContentsStrict 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 repo = do
+ let c = parse s
+ 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 }
+
+{- Updates the location of a repo, based on its configuration.
+ -
+ - Git.Construct makes LocalUknown repos, of which only a directory is
+ - known. Once the config is read, this can be fixed up to a Local repo,
+ - based on the core.bare and core.worktree settings.
+ -}
+updateLocation :: Repo -> IO Repo
+updateLocation r@(Repo { location = LocalUnknown d })
+ | isBare r = ifM (doesDirectoryExist dotgit)
+ ( updateLocation' r $ Local dotgit Nothing
+ , updateLocation' r $ Local d Nothing
+ )
+ | otherwise = updateLocation' r $ Local dotgit (Just d)
+ where
+ dotgit = (d </> ".git")
+updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
+updateLocation r = return r
+
+updateLocation' :: Repo -> RepoLocation -> IO Repo
+updateLocation' r l = do
+ l' <- case getMaybe "core.worktree" r of
+ Nothing -> return l
+ Just d -> do
+ {- core.worktree is relative to the gitdir -}
+ top <- absPath $ gitdir l
+ return $ l { worktree = Just $ absPathFrom top d }
+ 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
+ -- --list output will have an = in the first line
+ | all ('=' `elem`) (take 1 ls) = sep '=' ls
+ -- --null --list output separates keys from values with newlines
+ | otherwise = sep '\n' $ split "\0" s
+ where
+ ls = lines s
+ sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
+ map (separate (== c))
+
+{- Checks if a string from git config is a true value. -}
+isTrue :: String -> Maybe Bool
+isTrue s
+ | s' == "true" = Just True
+ | s' == "false" = Just False
+ | otherwise = Nothing
+ where
+ s' = map toLower s
+
+boolConfig :: Bool -> String
+boolConfig True = "true"
+boolConfig False = "false"
+
+isBare :: Repo -> Bool
+isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
+
+coreBare :: String
+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 r cmd params = try $
+ withHandle StdoutHandle createProcessSuccess p $ \h -> do
+ fileEncoding h
+ val <- hGetContentsStrict h
+ r' <- store val r
+ return (r', val)
+ where
+ p = proc cmd $ toCommand params
+
+{- Reads git config from a specified file and returns the repo populated
+ - with the configuration. -}
+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
+fromFile r f = fromPipe r "git"
+ [ Param "config"
+ , Param "--file"
+ , File f
+ , Param "--list"
+ ]
+
+{- 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"
+ [ Param "config"
+ , Param "--file"
+ , File f
+ , Param k
+ , Param v
+ ]
diff --git a/Git/Construct.hs b/Git/Construct.hs
new file mode 100644
index 0000000..71a13f4
--- /dev/null
+++ b/Git/Construct.hs
@@ -0,0 +1,236 @@
+{- Construction of Git Repo objects
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Git.Construct (
+ fromCwd,
+ fromAbsPath,
+ fromPath,
+ fromUrl,
+ fromUnknown,
+ localToUrl,
+ remoteNamed,
+ remoteNamedFromKey,
+ fromRemotes,
+ fromRemoteLocation,
+ repoAbsPath,
+ newFrom,
+ checkForRepo,
+) where
+
+#ifndef mingw32_HOST_OS
+import System.Posix.User
+#endif
+import qualified Data.Map as M hiding (map, split)
+import Network.URI
+
+import Common
+import Git.Types
+import Git
+import Git.Remote
+import qualified Git.Url as Url
+import Utility.UserInfo
+
+{- Finds the git repository used for the cwd, which may be in a parent
+ - directory. -}
+fromCwd :: IO (Maybe Repo)
+fromCwd = getCurrentDirectory >>= seekUp
+ where
+ seekUp dir = do
+ r <- checkForRepo dir
+ case r of
+ Nothing -> case parentDir dir of
+ "" -> return Nothing
+ d -> seekUp d
+ Just loc -> Just <$> newFrom loc
+
+{- Local Repo constructor, accepts a relative or absolute path. -}
+fromPath :: FilePath -> IO Repo
+fromPath dir = fromAbsPath =<< absPath dir
+
+{- Local Repo constructor, requires an absolute path to the repo be
+ - specified. -}
+fromAbsPath :: FilePath -> IO Repo
+fromAbsPath dir
+ | isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
+ | otherwise =
+ error $ "internal error, " ++ dir ++ " is not absolute"
+ where
+ ret = newFrom . LocalUnknown
+ {- Git always looks for "dir.git" in preference to
+ - to "dir", even if dir ends in a "/". -}
+ canondir = dropTrailingPathSeparator dir
+ dir' = canondir ++ ".git"
+ {- When dir == "foo/.git", git looks for "foo/.git/.git",
+ - and failing that, uses "foo" as the repository. -}
+ hunt
+ | (pathSeparator:".git") `isSuffixOf` canondir =
+ ifM (doesDirectoryExist $ dir </> ".git")
+ ( ret dir
+ , ret $ takeDirectory canondir
+ )
+ | otherwise = ret dir
+
+{- Remote Repo constructor. Throws exception on invalid url.
+ -
+ - Git is somewhat forgiving about urls to repositories, allowing
+ - eg spaces that are not normally allowed unescaped in urls.
+ -}
+fromUrl :: String -> IO Repo
+fromUrl url
+ | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
+ | otherwise = fromUrlStrict url
+
+fromUrlStrict :: String -> IO Repo
+fromUrlStrict url
+ | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u
+ | otherwise = newFrom $ Url u
+ where
+ u = fromMaybe bad $ parseURI url
+ bad = error $ "bad url " ++ url
+
+{- Creates a repo that has an unknown location. -}
+fromUnknown :: IO Repo
+fromUnknown = newFrom Unknown
+
+{- Converts a local Repo into a remote repo, using the reference repo
+ - which is assumed to be on the same host. -}
+localToUrl :: Repo -> Repo -> Repo
+localToUrl reference r
+ | not $ repoIsUrl reference = error "internal error; reference repo not url"
+ | repoIsUrl r = r
+ | otherwise = case Url.authority reference of
+ Nothing -> r
+ Just auth ->
+ let absurl = concat
+ [ Url.scheme reference
+ , "//"
+ , auth
+ , repoPath r
+ ]
+ in r { location = Url $ fromJust $ parseURI absurl }
+
+{- Calculates a list of a repo's configured remotes, by parsing its config. -}
+fromRemotes :: Repo -> IO [Repo]
+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 = startswith "remote." k && endswith ".url" k
+ construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
+
+{- Sets the name of a remote when constructing the Repo to represent it. -}
+remoteNamed :: String -> IO Repo -> IO Repo
+remoteNamed n constructor = do
+ r <- constructor
+ return $ r { remoteName = Just n }
+
+{- 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 $ split "." k
+
+{- Constructs a new Repo for one of a Repo's remotes using a given
+ - location (ie, an url). -}
+fromRemoteLocation :: String -> Repo -> IO Repo
+fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
+ where
+ gen (RemotePath p) = fromRemotePath p repo
+ gen (RemoteUrl u) = fromUrl u
+
+{- Constructs a Repo from the path specified in the git remotes of
+ - another Repo. -}
+fromRemotePath :: FilePath -> Repo -> IO Repo
+fromRemotePath dir repo = do
+ dir' <- expandTilde dir
+ fromAbsPath $ repoPath repo </> dir'
+
+{- Git remotes can have a directory that is specified relative
+ - to the user's home directory, or that contains tilde expansions.
+ - This converts such a directory to an absolute path.
+ - Note that it has to run on the system where the remote is.
+ -}
+repoAbsPath :: FilePath -> IO FilePath
+repoAbsPath d = do
+ d' <- expandTilde d
+ h <- myHomeDir
+ return $ h </> d'
+
+expandTilde :: FilePath -> IO FilePath
+#ifdef mingw32_HOST_OS
+expandTilde = return
+#else
+expandTilde = expandt True
+ where
+ expandt _ [] = return ""
+ expandt _ ('/':cs) = do
+ v <- expandt True cs
+ return ('/':v)
+ expandt True ('~':'/':cs) = do
+ h <- myHomeDir
+ return $ h </> cs
+ expandt True ('~':cs) = do
+ let (name, rest) = findname "" cs
+ u <- getUserEntryForName name
+ return $ homeDirectory u </> rest
+ expandt _ (c:cs) = do
+ v <- expandt False cs
+ return (c:v)
+ findname n [] = (n, "")
+ findname n (c:cs)
+ | c == '/' = (n, cs)
+ | otherwise = findname (n++[c]) cs
+#endif
+
+{- Checks if a git repository exists in a directory. Does not find
+ - git repositories in parent directories. -}
+checkForRepo :: FilePath -> IO (Maybe RepoLocation)
+checkForRepo dir =
+ check isRepo $
+ check gitDirFile $
+ check isBareRepo $
+ return Nothing
+ where
+ check test cont = maybe cont (return . Just) =<< test
+ checkdir c = ifM c
+ ( return $ Just $ LocalUnknown dir
+ , return Nothing
+ )
+ isRepo = checkdir $ gitSignature $ ".git" </> "config"
+ isBareRepo = checkdir $ gitSignature "config"
+ <&&> doesDirectoryExist (dir </> "objects")
+ gitDirFile = do
+ c <- firstLine <$>
+ catchDefaultIO "" (readFile $ dir </> ".git")
+ return $ if gitdirprefix `isPrefixOf` c
+ then Just $ Local
+ { gitdir = absPathFrom dir $
+ drop (length gitdirprefix) c
+ , worktree = Just dir
+ }
+ else Nothing
+ where
+ gitdirprefix = "gitdir: "
+ gitSignature file = doesFileExist $ dir </> file
+
+newFrom :: RepoLocation -> IO Repo
+newFrom l = return Repo
+ { location = l
+ , config = M.empty
+ , fullconfig = M.empty
+ , remotes = []
+ , remoteName = Nothing
+ , gitEnv = Nothing
+ , gitGlobalOpts = []
+ }
+
+
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
new file mode 100644
index 0000000..ee91a6b
--- /dev/null
+++ b/Git/CurrentRepo.hs
@@ -0,0 +1,67 @@
+{- The current git repository.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Git.CurrentRepo where
+
+import Common
+import Git.Types
+import Git.Construct
+import qualified Git.Config
+#ifndef mingw32_HOST_OS
+import Utility.Env
+#endif
+
+{- Gets the current git repository.
+ -
+ - Honors GIT_DIR and GIT_WORK_TREE.
+ - Both environment variables are unset, to avoid confusing other git
+ - commands that also look at them. Instead, the Git module passes
+ - --work-tree and --git-dir to git commands it runs.
+ -
+ - When GIT_WORK_TREE or core.worktree are set, changes the working
+ - 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.
+ -}
+get :: IO Repo
+get = do
+ gd <- pathenv "GIT_DIR"
+ r <- configure gd =<< fromCwd
+ wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE"
+ case wt of
+ Nothing -> return r
+ Just d -> do
+ cwd <- getCurrentDirectory
+ unless (d `dirContains` cwd) $
+ setCurrentDirectory d
+ return $ addworktree wt r
+ where
+#ifndef mingw32_HOST_OS
+ pathenv s = do
+ v <- getEnv s
+ case v of
+ Just d -> do
+ void $ unsetEnv s
+ Just <$> absPath d
+ Nothing -> return Nothing
+#else
+ pathenv _ = return Nothing
+#endif
+
+ configure Nothing (Just r) = Git.Config.read r
+ configure (Just d) _ = do
+ absd <- absPath d
+ cwd <- getCurrentDirectory
+ r <- newFrom $ Local { gitdir = absd, worktree = Just cwd }
+ Git.Config.read r
+ configure Nothing Nothing = error "Not in a git repository."
+
+ addworktree w r = changelocation r $
+ Local { gitdir = gitdir (location r), worktree = w }
+ changelocation r l = r { location = l }
diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
new file mode 100644
index 0000000..f460600
--- /dev/null
+++ b/Git/Destroyer.hs
@@ -0,0 +1,126 @@
+{- git repository destroyer
+ -
+ - Use with caution!
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Destroyer (
+ Damage(..),
+ generateDamage,
+ applyDamage
+) where
+
+import Common
+import Git
+import Utility.QuickCheck
+import Utility.FileMode
+
+import qualified Data.ByteString as B
+import Data.Word
+import System.PosixCompat.Types
+
+{- Ways to damange a git repository. -}
+data Damage = Damage DamageAction FileSelector
+ deriving (Read, Show)
+
+instance Arbitrary Damage where
+ arbitrary = Damage <$> arbitrary <*> arbitrary
+
+data DamageAction
+ = Empty
+ | Delete
+ | Reverse
+ | AppendGarbage B.ByteString
+ | PrependGarbage B.ByteString
+ | CorruptByte Int Word8
+ | ScrambleFileMode FileMode
+ deriving (Read, Show)
+
+instance Arbitrary DamageAction where
+ arbitrary = oneof
+ [ pure Empty
+ , pure Delete
+ , pure Reverse
+ , AppendGarbage <$> garbage
+ , PrependGarbage <$> garbage
+ , CorruptByte
+ <$> nonNegative arbitraryBoundedIntegral
+ <*> arbitrary
+ , ScrambleFileMode <$> nonNegative arbitrarySizedIntegral
+ ]
+ where
+ garbage = B.pack <$> arbitrary `suchThat` (not . null)
+
+{- To select a given file in a git repository, all files in the repository
+ - are enumerated, sorted, and this is used as an index
+ - into the list. (Wrapping around if higher than the length.) -}
+data FileSelector = FileSelector Int
+ deriving (Read, Show)
+
+instance Arbitrary FileSelector where
+ arbitrary = FileSelector <$> oneof
+ -- An early file in the git tree, tends to be the most
+ -- interesting when there are lots of files.
+ [ nonNegative arbitrarySizedIntegral
+ -- Totally random choice from any of the files in
+ -- the git tree, to ensure good coverage.
+ , nonNegative arbitraryBoundedIntegral
+ ]
+
+selectFile :: [FilePath] -> FileSelector -> FilePath
+selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs)
+
+{- Generates random Damage. -}
+generateDamage :: IO [Damage]
+generateDamage = sample' (arbitrary :: Gen Damage)
+
+{- Applies Damage to a Repo, in a reproducible fashion
+ - (as long as the Repo contains the same files each time). -}
+applyDamage :: [Damage] -> Repo -> IO ()
+applyDamage l r = do
+ contents <- sort . filter (not . skipped . takeFileName)
+ <$> dirContentsRecursive (localGitDir r)
+ forM_ l $ \(Damage action fileselector) -> do
+ let f = selectFile contents fileselector
+ -- Symlinks might be dangling, so are skipped.
+ -- If the file was already removed by a previous Damage,
+ -- it's skipped.
+ whenM (doesFileExist f) $
+ applyDamageAction action f
+ `catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show l ++ ")")
+ where
+ -- A broken .git/config is not recoverable.
+ skipped f = f `elem` [ "config" ]
+
+applyDamageAction :: DamageAction -> FilePath -> IO ()
+applyDamageAction Empty f = withSaneMode f $ do
+ nukeFile f
+ writeFile f ""
+applyDamageAction Reverse f = withSaneMode f $
+ B.writeFile f =<< B.reverse <$> B.readFile f
+applyDamageAction Delete f = nukeFile f
+applyDamageAction (AppendGarbage garbage) f = withSaneMode f $
+ B.appendFile f garbage
+applyDamageAction (PrependGarbage garbage) f = withSaneMode f $ do
+ b <- B.readFile f
+ B.writeFile f $ B.concat [garbage, b]
+-- When the byte is past the end of the file, wrap around.
+-- Does nothing to empty file.
+applyDamageAction (CorruptByte n garbage) f = withSaneMode f $ do
+ b <- B.readFile f
+ let len = B.length b
+ unless (len == 0) $ do
+ let n' = n `mod` len
+ let (prefix, rest) = B.splitAt n' b
+ B.writeFile f $ B.concat
+ [prefix
+ , B.singleton garbage
+ , B.drop 1 rest
+ ]
+applyDamageAction (ScrambleFileMode mode) f = setFileMode f mode
+
+withSaneMode :: FilePath -> IO () -> IO ()
+withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])
diff --git a/Git/FilePath.hs b/Git/FilePath.hs
new file mode 100644
index 0000000..37d740f
--- /dev/null
+++ b/Git/FilePath.hs
@@ -0,0 +1,64 @@
+{- git FilePath library
+ -
+ - Different git commands use different types of FilePaths to refer to
+ - files in the repository. Some commands use paths relative to the
+ - top of the repository even when run in a subdirectory. Adding some
+ - types helps keep that straight.
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Git.FilePath (
+ TopFilePath,
+ fromTopFilePath,
+ getTopFilePath,
+ toTopFilePath,
+ asTopFilePath,
+ InternalGitPath,
+ toInternalGitPath,
+ fromInternalGitPath
+) where
+
+import Common
+import Git
+
+{- A FilePath, relative to the top of the git repository. -}
+newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
+ deriving (Show)
+
+{- Returns an absolute FilePath. -}
+fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
+fromTopFilePath p repo = absPathFrom (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) <$> absPath file
+
+{- The input FilePath must already be relative to the top of the git
+ - repository -}
+asTopFilePath :: FilePath -> TopFilePath
+asTopFilePath file = TopFilePath file
+
+{- Git may use a different representation of a path when storing
+ - it internally. For example, on Windows, git uses '/' to separate paths
+ - stored in the repository, despite Windows using '\' -}
+type InternalGitPath = String
+
+toInternalGitPath :: FilePath -> InternalGitPath
+#ifndef mingw32_HOST_OS
+toInternalGitPath = id
+#else
+toInternalGitPath = replace "\\" "/"
+#endif
+
+fromInternalGitPath :: InternalGitPath -> FilePath
+#ifndef mingw32_HOST_OS
+fromInternalGitPath = id
+#else
+fromInternalGitPath = replace "/" "\\"
+#endif
diff --git a/Git/Filename.hs b/Git/Filename.hs
new file mode 100644
index 0000000..5e076d3
--- /dev/null
+++ b/Git/Filename.hs
@@ -0,0 +1,28 @@
+{- Some git commands output encoded filenames, in a rather annoyingly complex
+ - C-style encoding.
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Filename where
+
+import Utility.Format (decode_c, encode_c)
+
+import Common
+
+decode :: String -> FilePath
+decode [] = []
+decode f@(c:s)
+ -- encoded strings will be inside double quotes
+ | c == '"' && end s == ['"'] = decode_c $ beginning s
+ | otherwise = f
+
+{- Should not need to use this, except for testing decode. -}
+encode :: FilePath -> String
+encode s = "\"" ++ encode_c s ++ "\""
+
+{- for quickcheck -}
+prop_idempotent_deencode :: String -> Bool
+prop_idempotent_deencode s = s == decode (encode s)
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
new file mode 100644
index 0000000..8d5b75b
--- /dev/null
+++ b/Git/Fsck.hs
@@ -0,0 +1,81 @@
+{- git fsck interface
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Fsck (
+ FsckResults(..),
+ MissingObjects,
+ findBroken,
+ foundBroken,
+ findMissing,
+ knownMissing,
+) where
+
+import Common
+import Git
+import Git.Command
+import Git.Sha
+import Utility.Batch
+
+import qualified Data.Set as S
+
+type MissingObjects = S.Set Sha
+
+data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
+
+{- 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
+ - the broken objects it does find.
+ -
+ - Strategy: Rather than parsing fsck's current specific output,
+ - look for anything in its output (both stdout and stderr) that appears
+ - to be a git sha. Not all such shas are of broken objects, so ask git
+ - to try to cat the object, and see if it fails.
+ -}
+findBroken :: Bool -> Repo -> IO FsckResults
+findBroken batchmode r = do
+ let (command, params) = ("git", fsckParams r)
+ (command', params') <- if batchmode
+ then toBatchCommand (command, params)
+ else return (command, params)
+ (output, fsckok) <- processTranscript command' (toCommand params') Nothing
+ let objs = findShas output
+ badobjs <- findMissing objs r
+ if S.null badobjs && not fsckok
+ then return FsckFailed
+ else return $ FsckFoundMissing badobjs
+
+foundBroken :: FsckResults -> Bool
+foundBroken FsckFailed = True
+foundBroken (FsckFoundMissing s) = not (S.null s)
+
+knownMissing :: FsckResults -> MissingObjects
+knownMissing FsckFailed = S.empty
+knownMissing (FsckFoundMissing s) = s
+
+{- Finds objects that are missing from the git repsitory, or are corrupt.
+ -
+ - This does not use git cat-file --batch, because catting a corrupt
+ - object can cause it to crash, or to report incorrect size information.a
+ -}
+findMissing :: [Sha] -> Repo -> IO MissingObjects
+findMissing objs r = S.fromList <$> filterM (not <$$> present) objs
+ where
+ present o = either (const False) (const True) <$> tryIO (dump o)
+ dump o = runQuiet
+ [ Param "show"
+ , Param (show o)
+ ] r
+
+findShas :: String -> [Sha]
+findShas = catMaybes . map extractSha . concat . map words . lines
+
+fsckParams :: Repo -> [CommandParam]
+fsckParams = gitCommandLine $
+ [ Param "fsck"
+ , Param "--no-dangling"
+ , Param "--no-reflogs"
+ ]
diff --git a/Git/Index.hs b/Git/Index.hs
new file mode 100644
index 0000000..d9d5b03
--- /dev/null
+++ b/Git/Index.hs
@@ -0,0 +1,32 @@
+{- git index file stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Index where
+
+import Common
+import Git
+import Utility.Env
+
+{- Forces git to use the specified index file.
+ -
+ - Returns an action that will reset back to the default
+ - index file.
+ -
+ - Warning: Not thread safe.
+ -}
+override :: FilePath -> IO (IO ())
+override index = do
+ res <- getEnv var
+ void $ setEnv var index True
+ return $ void $ reset res
+ where
+ var = "GIT_INDEX_FILE"
+ reset (Just v) = setEnv var v True
+ reset _ = unsetEnv var
+
+indexFile :: Repo -> FilePath
+indexFile r = localGitDir r </> "index"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
new file mode 100644
index 0000000..8aaa090
--- /dev/null
+++ b/Git/LsFiles.hs
@@ -0,0 +1,214 @@
+{- git ls-files interface
+ -
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.LsFiles (
+ inRepo,
+ notInRepo,
+ allFiles,
+ deleted,
+ modified,
+ modifiedOthers,
+ staged,
+ stagedNotDeleted,
+ stagedOthersDetails,
+ stagedDetails,
+ typeChanged,
+ typeChangedStaged,
+ Conflicting(..),
+ Unmerged(..),
+ unmerged,
+ StagedDetails,
+) where
+
+import Common
+import Git
+import Git.Command
+import Git.Types
+import Git.Sha
+
+import Numeric
+import System.Posix.Types
+
+{- Scans for files that are checked into git at the specified locations. -}
+inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l
+
+{- 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
+ where
+ params = [Params "ls-files --others"] ++ exclude ++
+ [Params "-z --"] ++ map File l
+ exclude
+ | include_ignored = []
+ | otherwise = [Param "--exclude-standard"]
+
+{- Finds all files in the specified locations, whether checked into git or
+ - not. -}
+allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+allFiles l = pipeNullSplit $ Params "ls-files --cached --others -z --" : map File 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
+ where
+ params = [Params "ls-files --deleted -z --"] ++ map File 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
+ where
+ params = [Params "ls-files --modified -z --"] ++ map File l
+
+{- Files that have been modified or are not checked into git. -}
+modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+modifiedOthers l repo = pipeNullSplit params repo
+ where
+ params = [Params "ls-files --modified --others -z --"] ++ map File l
+
+{- Returns a list of all files that are staged for commit. -}
+staged :: [FilePath] -> Repo -> IO ([FilePath], 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 = staged' [Param "--diff-filter=ACMRT"]
+
+staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
+ where
+ prefix = [Params "diff --cached --name-only -z"]
+ suffix = Param "--" : map File l
+
+type StagedDetails = (FilePath, 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 = stagedDetails' [Params "--others --exclude-standard"]
+
+{- Returns details about all files that are staged in the index. -}
+stagedDetails :: [FilePath] -> 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' ps l repo = do
+ (ls, cleanup) <- pipeNullSplit params repo
+ return (map parse ls, cleanup)
+ where
+ params = Params "ls-files --stage -z" : ps ++
+ Param "--" : map File l
+ parse s
+ | null file = (s, Nothing, Nothing)
+ | otherwise = (file, extractSha $ take shaSize rest, readmode mode)
+ where
+ (metadata, file) = separate (== '\t') 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 = 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 = typeChanged' []
+
+typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], 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.
+ let top = repoPath repo
+ cwd <- getCurrentDirectory
+ return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)
+ where
+ prefix = [Params "diff --name-only --diff-filter=T -z"]
+ suffix = Param "--" : (if null l then [File "."] else map File l)
+
+{- A item in conflict has two possible values.
+ - Either can be Nothing, when that side deleted the file. -}
+data Conflicting v = Conflicting
+ { valUs :: Maybe v
+ , valThem :: Maybe v
+ } deriving (Show)
+
+data Unmerged = Unmerged
+ { unmergedFile :: FilePath
+ , unmergedBlobType :: Conflicting BlobType
+ , unmergedSha :: Conflicting Sha
+ } deriving (Show)
+
+{- Returns a list of the files in the specified locations that have
+ - unresolved merge conflicts.
+ -
+ - ls-files outputs multiple lines per conflicting file, each with its own
+ - stage number:
+ - 1 = old version, can be ignored
+ - 2 = us
+ - 3 = them
+ - If a line is omitted, that side removed the file.
+ -}
+unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)
+unmerged l repo = do
+ (fs, cleanup) <- pipeNullSplit params repo
+ return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
+ where
+ params = Params "ls-files --unmerged -z --" : map File l
+
+data InternalUnmerged = InternalUnmerged
+ { isus :: Bool
+ , ifile :: FilePath
+ , iblobtype :: Maybe BlobType
+ , isha :: Maybe Sha
+ } deriving (Show)
+
+parseUnmerged :: String -> Maybe InternalUnmerged
+parseUnmerged s
+ | null file = Nothing
+ | otherwise = case words metadata of
+ (rawblobtype:rawsha:rawstage:_) -> do
+ stage <- readish rawstage :: Maybe Int
+ unless (stage == 2 || stage == 3) $
+ fail undefined -- skip stage 1
+ blobtype <- readBlobType rawblobtype
+ sha <- extractSha rawsha
+ return $ InternalUnmerged (stage == 2) file
+ (Just blobtype) (Just sha)
+ _ -> Nothing
+ where
+ (metadata, file) = separate (== '\t') s
+
+reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged]
+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)
+ new = Unmerged
+ { unmergedFile = ifile i
+ , unmergedBlobType = Conflicting blobtypeA blobtypeB
+ , unmergedSha = Conflicting shaA shaB
+ }
+ findsib templatei [] = ([], removed templatei)
+ findsib templatei (l:ls)
+ | ifile l == ifile templatei = (ls, l)
+ | otherwise = (l:ls, removed templatei)
+ removed templatei = templatei
+ { isus = not (isus templatei)
+ , iblobtype = Nothing
+ , isha = Nothing
+ }
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
new file mode 100644
index 0000000..956f9f5
--- /dev/null
+++ b/Git/LsTree.hs
@@ -0,0 +1,65 @@
+{- git ls-tree interface
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.LsTree (
+ TreeItem(..),
+ lsTree,
+ lsTreeParams,
+ lsTreeFiles,
+ parseLsTree
+) where
+
+import Numeric
+import Control.Applicative
+import System.Posix.Types
+
+import Common
+import Git
+import Git.Command
+import Git.Sha
+import Git.FilePath
+import qualified Git.Filename
+
+data TreeItem = TreeItem
+ { mode :: FileMode
+ , typeobj :: String
+ , sha :: String
+ , file :: TopFilePath
+ } deriving Show
+
+{- Lists the complete contents of a tree, recursing into sub-trees,
+ - with lazy output. -}
+lsTree :: Ref -> Repo -> IO [TreeItem]
+lsTree t repo = map parseLsTree
+ <$> pipeNullSplitZombie (lsTreeParams t) repo
+
+lsTreeParams :: Ref -> [CommandParam]
+lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]
+
+{- Lists specified files in a tree. -}
+lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
+lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo
+ where
+ ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs
+
+{- Parses a line of ls-tree output.
+ - (The --long format is not currently supported.) -}
+parseLsTree :: String -> TreeItem
+parseLsTree l = TreeItem
+ { mode = fst $ Prelude.head $ readOct m
+ , typeobj = t
+ , sha = s
+ , file = asTopFilePath $ Git.Filename.decode f
+ }
+ where
+ -- l = <mode> SP <type> SP <sha> TAB <file>
+ -- All fields are fixed, so we can pull them out of
+ -- specific positions in the line.
+ (m, past_m) = splitAt 7 l
+ (t, past_t) = splitAt 4 past_m
+ (s, past_s) = splitAt shaSize $ Prelude.tail past_t
+ f = Prelude.tail past_s
diff --git a/Git/Objects.hs b/Git/Objects.hs
new file mode 100644
index 0000000..d9d2c67
--- /dev/null
+++ b/Git/Objects.hs
@@ -0,0 +1,35 @@
+{- .git/objects
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Objects where
+
+import Common
+import Git
+import Git.Sha
+
+objectsDir :: Repo -> FilePath
+objectsDir r = localGitDir r </> "objects"
+
+packDir :: Repo -> FilePath
+packDir r = objectsDir r </> "pack"
+
+packIdxFile :: FilePath -> FilePath
+packIdxFile = flip replaceExtension "idx"
+
+listPackFiles :: Repo -> IO [FilePath]
+listPackFiles r = filter (".pack" `isSuffixOf`)
+ <$> catchDefaultIO [] (dirContents $ packDir r)
+
+listLooseObjectShas :: Repo -> IO [Sha]
+listLooseObjectShas r = catchDefaultIO [] $
+ mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
+ <$> dirContentsRecursiveSkipping (== "pack") (objectsDir r)
+
+looseObjectFile :: Repo -> Sha -> FilePath
+looseObjectFile r sha = objectsDir r </> prefix </> rest
+ where
+ (prefix, rest) = splitAt 2 (show sha)
diff --git a/Git/Ref.hs b/Git/Ref.hs
new file mode 100644
index 0000000..0947293
--- /dev/null
+++ b/Git/Ref.hs
@@ -0,0 +1,139 @@
+{- git ref stuff
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Ref where
+
+import Common
+import Git
+import Git.Command
+import Git.Sha
+
+import Data.Char (chr)
+
+headRef :: Ref
+headRef = Ref "HEAD"
+
+{- Converts a fully qualified git ref into a user-visible string. -}
+describe :: Ref -> String
+describe = show . base
+
+{- Often git refs are fully qualified (eg: refs/heads/master).
+ - Converts such a fully qualified ref into a base ref (eg: master). -}
+base :: Ref -> Ref
+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
+ where
+ remove prefix s
+ | prefix `isPrefixOf` s = drop (length prefix) s
+ | otherwise = s
+
+{- Given a directory and any ref, takes the basename of the ref and puts
+ - it under the directory. -}
+under :: String -> Ref -> Ref
+under dir r = Ref $ dir ++ "/" ++
+ (reverse $ takeWhile (/= '/') $ reverse $ show r)
+
+{- Given a directory such as "refs/remotes/origin", and a ref such as
+ - refs/heads/master, yields a version of that ref under the directory,
+ - such as refs/remotes/origin/master. -}
+underBase :: String -> Ref -> Ref
+underBase dir r = Ref $ dir ++ "/" ++ show (base r)
+
+{- A Ref that can be used to refer to a file in the repository, as staged
+ - in the index.
+ -
+ - Prefixing the file with ./ makes this work even if in a subdirectory
+ - of a repo.
+ -}
+fileRef :: FilePath -> Ref
+fileRef f = Ref $ ":./" ++ f
+
+{- 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 r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
+
+{- Checks if a ref exists. -}
+exists :: Ref -> Repo -> IO Bool
+exists ref = runBool
+ [Param "show-ref", Param "--verify", Param "-q", Param $ show ref]
+
+{- The file used to record a ref. (Git also stores some refs in a
+ - packed-refs file.) -}
+file :: Ref -> Repo -> FilePath
+file ref repo = localGitDir repo </> show 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
+
+{- 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 $ show branch]
+ process [] = Nothing
+ process s = Just $ Ref $ firstLine s
+
+{- List of (shas, branches) matching a given ref or refs. -}
+matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
+matching refs repo = matching' (map show refs) repo
+
+{- Includes HEAD in the output, if asked for it. -}
+matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
+matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo
+
+{- List of (shas, branches) matching a given ref or refs. -}
+matching' :: [String] -> Repo -> IO [(Sha, Branch)]
+matching' ps repo = map gen . lines <$>
+ pipeReadStrict (Param "show-ref" : map Param ps) repo
+ where
+ gen l = let (r, b) = separate (== ' ') l
+ in (Ref r, Ref b)
+
+{- List of (shas, branches) matching a given ref spec.
+ - Duplicate shas are filtered out. -}
+matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)]
+matchingUniq refs repo = nubBy uniqref <$> matching refs repo
+ where
+ uniqref (a, _) (b, _) = a == b
+
+{- Gets the sha of the tree a ref uses. -}
+tree :: Ref -> Repo -> IO (Maybe Sha)
+tree ref = extractSha <$$> pipeReadStrict
+ [ Param "rev-parse", Param (show ref ++ ":") ]
+
+{- Checks if a String is a legal git ref name.
+ -
+ - The rules for this are complex; see git-check-ref-format(1) -}
+legal :: Bool -> String -> Bool
+legal allowonelevel s = all (== False) illegal
+ where
+ illegal =
+ [ any ("." `isPrefixOf`) pathbits
+ , any (".lock" `isSuffixOf`) pathbits
+ , not allowonelevel && length pathbits < 2
+ , contains ".."
+ , any (\c -> contains [c]) illegalchars
+ , begins "/"
+ , ends "/"
+ , contains "//"
+ , ends "."
+ , contains "@{"
+ , null s
+ ]
+ contains v = v `isInfixOf` s
+ ends v = v `isSuffixOf` s
+ begins v = v `isPrefixOf` s
+
+ pathbits = split "/" s
+ illegalchars = " ~^:?*[\\" ++ controlchars
+ controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
diff --git a/Git/RefLog.hs b/Git/RefLog.hs
new file mode 100644
index 0000000..3f41e8e
--- /dev/null
+++ b/Git/RefLog.hs
@@ -0,0 +1,22 @@
+{- git reflog interface
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.RefLog where
+
+import Common
+import Git
+import Git.Command
+import Git.Sha
+
+{- Gets the reflog for a given branch. -}
+get :: Branch -> Repo -> IO [Sha]
+get b = mapMaybe extractSha . lines <$$> pipeReadStrict
+ [ Param "log"
+ , Param "-g"
+ , Param "--format=%H"
+ , Param (show b)
+ ]
diff --git a/Git/Remote.hs b/Git/Remote.hs
new file mode 100644
index 0000000..9d969c4
--- /dev/null
+++ b/Git/Remote.hs
@@ -0,0 +1,115 @@
+{- git remote stuff
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Git.Remote where
+
+import Common
+import Git
+import Git.Types
+import qualified Git.Command
+import qualified Git.BuildVersion
+
+import Data.Char
+import qualified Data.Map as M
+import Network.URI
+#ifdef mingw32_HOST_OS
+import Git.FilePath
+#endif
+
+{- 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,
+ - just some ad-hoc checks, and some other things that fail with certian
+ - types of names (like ones starting with '-').
+ -}
+makeLegalName :: String -> RemoteName
+makeLegalName s = case filter legal $ replace "/" "_" s of
+ -- it can't be empty
+ [] -> "unnamed"
+ -- it can't start with / or - or .
+ '.':s' -> makeLegalName s'
+ '/':s' -> makeLegalName s'
+ '-':s' -> makeLegalName s'
+ s' -> s'
+ where
+ {- Only alphanumerics, and a few common bits of punctuation common
+ - in hostnames. -}
+ legal '_' = True
+ legal '.' = True
+ legal c = isAlphaNum c
+
+remove :: RemoteName -> Repo -> IO ()
+remove remotename = Git.Command.run
+ [ Param "remote"
+ -- name of this subcommand changed
+ , Param $
+ if Git.BuildVersion.older "1.8.0"
+ then "rm"
+ else "remove"
+ , Param remotename
+ ]
+
+data RemoteLocation = RemoteUrl String | RemotePath FilePath
+
+remoteLocationIsUrl :: RemoteLocation -> Bool
+remoteLocationIsUrl (RemoteUrl _) = True
+remoteLocationIsUrl _ = False
+
+remoteLocationIsSshUrl :: RemoteLocation -> Bool
+remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u
+remoteLocationIsSshUrl _ = False
+
+{- Determines if a given remote location is an url, or a local
+ - path. Takes the repository's insteadOf configuration into account. -}
+parseRemoteLocation :: String -> Repo -> RemoteLocation
+parseRemoteLocation s repo = ret $ calcloc s
+ where
+ ret v
+#ifdef mingw32_HOST_OS
+ | dosstyle v = RemotePath (dospath v)
+#endif
+ | scpstyle v = RemoteUrl (scptourl v)
+ | urlstyle v = RemoteUrl v
+ | otherwise = RemotePath v
+ -- insteadof config can rewrite remote location
+ calcloc l
+ | null insteadofs = l
+ | otherwise = replacement ++ drop (length bestvalue) l
+ where
+ replacement = drop (length prefix) $
+ take (length bestkey - length suffix) bestkey
+ (bestkey, bestvalue) = maximumBy longestvalue insteadofs
+ longestvalue (_, a) (_, b) = compare b a
+ insteadofs = filterconfig $ \(k, v) ->
+ startswith prefix k &&
+ endswith suffix k &&
+ startswith v l
+ filterconfig f = filter f $
+ concatMap splitconfigs $ M.toList $ fullconfig repo
+ splitconfigs (k, vs) = map (\v -> (k, v)) vs
+ (prefix, suffix) = ("url." , ".insteadof")
+ urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
+ -- git remotes can be written scp style -- [user@]host:dir
+ -- but foo::bar is a git-remote-helper location instead
+ scpstyle v = ":" `isInfixOf` v
+ && not ("//" `isInfixOf` v)
+ && not ("::" `isInfixOf` v)
+ scptourl v = "ssh://" ++ host ++ slash dir
+ where
+ (host, dir) = separate (== ':') v
+ slash d | d == "" = "/~/" ++ d
+ | "/" `isPrefixOf` d = d
+ | "~" `isPrefixOf` d = '/':d
+ | otherwise = "/~/" ++ d
+#ifdef mingw32_HOST_OS
+ -- 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
+#endif
diff --git a/Git/Repair.hs b/Git/Repair.hs
new file mode 100644
index 0000000..5afa5f9
--- /dev/null
+++ b/Git/Repair.hs
@@ -0,0 +1,548 @@
+{- git repository recovery
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Repair (
+ runRepair,
+ runRepairOf,
+ successfulRepair,
+ cleanCorruptObjects,
+ retrieveMissingObjects,
+ resetLocalBranches,
+ removeTrackingBranches,
+ checkIndex,
+ missingIndex,
+ emptyGoodCommits,
+) where
+
+import Common
+import Git
+import Git.Command
+import Git.Objects
+import Git.Sha
+import Git.Types
+import Git.Fsck
+import Git.Index
+import qualified Git.Config as Config
+import qualified Git.Construct as Construct
+import qualified Git.LsTree as LsTree
+import qualified Git.LsFiles as LsFiles
+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.Rsync
+import Utility.FileMode
+
+import qualified Data.Set as S
+import qualified Data.ByteString.Lazy as L
+import Data.Tuple.Utils
+
+{- Given a set of bad objects found by git fsck, which may not
+ - be complete, finds and removes all corrupt objects,
+ - and returns missing objects.
+ -}
+cleanCorruptObjects :: FsckResults -> Repo -> IO FsckResults
+cleanCorruptObjects fsckresults r = do
+ void $ explodePacks r
+ objs <- listLooseObjectShas r
+ mapM_ (tryIO . allowRead . looseObjectFile r) objs
+ bad <- findMissing objs r
+ void $ removeLoose r $ S.union bad (knownMissing fsckresults)
+ -- Rather than returning the loose objects that were removed, re-run
+ -- fsck. Other missing objects may have been in the packs,
+ -- and this way fsck will find them.
+ findBroken False r
+
+removeLoose :: Repo -> MissingObjects -> IO Bool
+removeLoose r s = do
+ fs <- filterM doesFileExist (map (looseObjectFile r) (S.toList s))
+ let count = length fs
+ if count > 0
+ then do
+ putStrLn $ unwords
+ [ "Removing"
+ , show count
+ , "corrupt loose objects."
+ ]
+ mapM_ nukeFile fs
+ return True
+ else return False
+
+explodePacks :: Repo -> IO Bool
+explodePacks r = do
+ packs <- listPackFiles r
+ if null packs
+ then return False
+ else do
+ putStrLn "Unpacking all pack files."
+ mapM_ go packs
+ return True
+ where
+ go packfile = withTmpFileIn (localGitDir r) "pack" $ \tmp _ -> do
+ moveFile packfile tmp
+ nukeFile $ packIdxFile packfile
+ allowRead tmp
+ -- May fail, if pack file is corrupt.
+ void $ tryIO $
+ pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
+ L.hPut h =<< L.readFile tmp
+
+{- Try to retrieve a set of missing objects, from the remotes of a
+ - repository. Returns any that could not be retreived.
+ -
+ - If another clone of the repository exists locally, which might not be a
+ - remote of the repo being repaired, its path can be passed as a reference
+ - repository.
+ -}
+retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
+retrieveMissingObjects missing referencerepo r
+ | not (foundBroken missing) = return missing
+ | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
+ unlessM (boolSystem "git" [Params "init", File tmpdir]) $
+ error $ "failed to create temp repository in " ++ tmpdir
+ tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
+ stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
+ if S.null (knownMissing stillmissing)
+ then return stillmissing
+ else pullremotes tmpr (remotes r) fetchallrefs stillmissing
+ where
+ pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
+ Nothing -> return stillmissing
+ Just p -> ifM (fetchfrom p fetchrefs tmpr)
+ ( do
+ void $ explodePacks tmpr
+ void $ copyObjects tmpr r
+ case stillmissing of
+ FsckFailed -> return $ FsckFailed
+ FsckFoundMissing s -> FsckFoundMissing <$> findMissing (S.toList s) r
+ , return stillmissing
+ )
+ pullremotes tmpr (rmt:rmts) fetchrefs ms
+ | not (foundBroken ms) = return ms
+ | otherwise = do
+ putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."
+ ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
+ ( do
+ void $ explodePacks tmpr
+ void $ copyObjects tmpr r
+ case ms of
+ FsckFailed -> pullremotes tmpr rmts fetchrefs ms
+ FsckFoundMissing s -> do
+ stillmissing <- findMissing (S.toList s) r
+ pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing)
+ , pullremotes tmpr rmts fetchrefs ms
+ )
+ fetchfrom fetchurl ps = runBool $
+ [ Param "fetch"
+ , Param fetchurl
+ , Params "--force --update-head-ok --quiet"
+ ] ++ ps
+ -- fetch refs and tags
+ fetchrefstags = [ Param "+refs/heads/*:refs/heads/*", Param "--tags"]
+ -- Fetch all available refs (more likely to fail,
+ -- as the remote may have refs it refuses to send).
+ fetchallrefs = [ Param "+*:*" ]
+
+{- Copies all objects from the src repository to the dest repository.
+ - This is done using rsync, so it copies all missing objects, and all
+ - objects they rely on. -}
+copyObjects :: Repo -> Repo -> IO Bool
+copyObjects srcr destr = rsync
+ [ Param "-qr"
+ , File $ addTrailingPathSeparator $ objectsDir srcr
+ , File $ addTrailingPathSeparator $ objectsDir destr
+ ]
+
+{- To deal with missing objects that cannot be recovered, resets any
+ - local branches to point to an old commit before the missing
+ - objects. Returns all branches that were changed, and deleted.
+ -}
+resetLocalBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], [Branch], GoodCommits)
+resetLocalBranches missing goodcommits r =
+ go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r
+ where
+ islocalbranch b = "refs/heads/" `isPrefixOf` show b
+ go changed deleted gcs [] = return (changed, deleted, gcs)
+ go changed deleted gcs (b:bs) = do
+ (mc, gcs') <- findUncorruptedCommit missing gcs b r
+ case mc of
+ Just c
+ | c == b -> go changed deleted gcs' bs
+ | otherwise -> do
+ reset b c
+ go (b:changed) deleted gcs' bs
+ Nothing -> do
+ nukeBranchRef b r
+ go changed (b:deleted) gcs' bs
+ reset b c = do
+ nukeBranchRef b r
+ void $ runBool
+ [ Param "branch"
+ , Param (show $ Ref.base b)
+ , Param (show c)
+ ] r
+
+{- To deal with missing objects that cannot be recovered, removes
+ - any remote tracking branches that reference them. Returns a list of
+ - all removed branches.
+ -}
+removeTrackingBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits)
+removeTrackingBranches missing goodcommits r =
+ go [] goodcommits =<< filter istrackingbranch <$> getAllRefs r
+ where
+ istrackingbranch b = "refs/remotes/" `isPrefixOf` show b
+ go removed gcs [] = return (removed, gcs)
+ go removed gcs (b:bs) = do
+ (ok, gcs') <- verifyCommit missing gcs b r
+ if ok
+ then go removed gcs' bs
+ else do
+ nukeBranchRef b r
+ go (b:removed) gcs' bs
+
+{- Gets all refs, including ones that are corrupt.
+ - git show-ref does not output refs to commits that are directly
+ - corrupted, so it is not used.
+ -
+ - Relies on packed refs being exploded before it's called.
+ -}
+getAllRefs :: Repo -> IO [Ref]
+getAllRefs r = map toref <$> dirContentsRecursive refdir
+ where
+ refdir = localGitDir r </> "refs"
+ toref = Ref . relPathDirToFile (localGitDir r)
+
+explodePackedRefsFile :: Repo -> IO ()
+explodePackedRefsFile r = do
+ let f = packedRefsFile r
+ whenM (doesFileExist f) $ do
+ rs <- mapMaybe parsePacked . lines
+ <$> catchDefaultIO "" (safeReadFile f)
+ forM_ rs makeref
+ nukeFile f
+ where
+ makeref (sha, ref) = do
+ let dest = localGitDir r ++ show ref
+ createDirectoryIfMissing True (parentDir dest)
+ unlessM (doesFileExist dest) $
+ writeFile dest (show sha)
+
+packedRefsFile :: Repo -> FilePath
+packedRefsFile r = localGitDir r </> "packed-refs"
+
+parsePacked :: String -> Maybe (Sha, Ref)
+parsePacked l = case words l of
+ (sha:ref:[])
+ | isJust (extractSha sha) && Ref.legal True ref ->
+ Just (Ref sha, Ref ref)
+ _ -> Nothing
+
+{- 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 </> show 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.
+ - Otherwise, tries to traverse the commits in the branch to find one
+ - that is ok. That might fail, if one of them is corrupt, or if an object
+ - at the root of the branch is missing. Finally, looks for an old version
+ - of the branch from the reflog.
+ -}
+findUncorruptedCommit :: MissingObjects -> GoodCommits -> Branch -> Repo -> IO (Maybe Sha, GoodCommits)
+findUncorruptedCommit missing goodcommits branch r = do
+ (ok, goodcommits') <- verifyCommit missing goodcommits branch r
+ if ok
+ then return (Just branch, goodcommits')
+ else do
+ (ls, cleanup) <- pipeNullSplit
+ [ Param "log"
+ , Param "-z"
+ , Param "--format=%H"
+ , Param (show branch)
+ ] r
+ let branchshas = catMaybes $ map extractSha ls
+ reflogshas <- RefLog.get branch r
+ -- XXX Could try a bit harder here, and look
+ -- for uncorrupted old commits in branches in the
+ -- reflog.
+ cleanup `after` findfirst goodcommits (branchshas ++ reflogshas)
+ where
+ findfirst gcs [] = return (Nothing, gcs)
+ findfirst gcs (c:cs) = do
+ (ok, gcs') <- verifyCommit missing gcs c r
+ if ok
+ then return (Just c, gcs')
+ else findfirst gcs' cs
+
+{- Verifies tha none of the missing objects in the set are used by
+ - the commit. Also adds to a set of commit shas that have been verified to
+ - be good, which can be passed into subsequent calls to avoid
+ - redundant work when eg, chasing down branches to find the first
+ - uncorrupted commit. -}
+verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits)
+verifyCommit missing goodcommits commit r
+ | checkGoodCommit commit goodcommits = return (True, goodcommits)
+ | otherwise = do
+ (ls, cleanup) <- pipeNullSplit
+ [ Param "log"
+ , Param "-z"
+ , Param "--format=%H %T"
+ , Param (show commit)
+ ] r
+ let committrees = map parse ls
+ if any isNothing committrees || null committrees
+ then do
+ void cleanup
+ return (False, goodcommits)
+ else do
+ let cts = catMaybes committrees
+ ifM (cleanup <&&> check cts)
+ ( return (True, addGoodCommits (map fst cts) goodcommits)
+ , return (False, goodcommits)
+ )
+ where
+ parse l = case words l of
+ (commitsha:treesha:[]) -> (,)
+ <$> extractSha commitsha
+ <*> extractSha treesha
+ _ -> Nothing
+ check [] = return True
+ check ((c, t):rest)
+ | checkGoodCommit c goodcommits = return True
+ | otherwise = verifyTree missing t r <&&> check rest
+
+{- Verifies that a tree is good, including all trees and blobs
+ - referenced by it. -}
+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 (extractSha . LsTree.sha . LsTree.parseLsTree) ls
+ if any isNothing objshas || any (`S.member` missing) (catMaybes objshas)
+ then do
+ void cleanup
+ return False
+ -- as long as ls-tree succeeded, we're good
+ else cleanup
+
+{- Checks that the index file only refers to objects that are not missing,
+ - and is not itself corrupt. Note that a missing index file is not
+ - considered a problem (repo may be new). -}
+checkIndex :: MissingObjects -> Repo -> IO Bool
+checkIndex missing r = do
+ (bad, _good, cleanup) <- partitionIndex missing r
+ if null bad
+ then cleanup
+ else do
+ void cleanup
+ return False
+
+missingIndex :: Repo -> IO Bool
+missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
+
+partitionIndex :: MissingObjects -> Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
+partitionIndex missing r = do
+ (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
+ let (bad, good) = partition ismissing indexcontents
+ return (bad, good, cleanup)
+ where
+ getblob (_file, Just sha, Just _mode) = Just sha
+ getblob _ = Nothing
+ ismissing = maybe False (`S.member` missing) . getblob
+
+{- Rewrites the index file, removing from it any files whose blobs are
+ - missing. Returns the list of affected files. -}
+rewriteIndex :: MissingObjects -> Repo -> IO [FilePath]
+rewriteIndex missing r
+ | repoIsLocalBare r = return []
+ | otherwise = do
+ (bad, good, cleanup) <- partitionIndex missing r
+ unless (null bad) $ do
+ nukeFile (indexFile r)
+ UpdateIndex.streamUpdateIndex r
+ =<< (catMaybes <$> mapM reinject good)
+ void cleanup
+ return $ map fst3 bad
+ where
+ reinject (file, Just sha, Just mode) = case toBlobType mode of
+ Nothing -> return Nothing
+ Just blobtype -> Just <$>
+ UpdateIndex.stageFile sha blobtype file r
+ reinject _ = return Nothing
+
+newtype GoodCommits = GoodCommits (S.Set Sha)
+
+emptyGoodCommits :: GoodCommits
+emptyGoodCommits = GoodCommits S.empty
+
+checkGoodCommit :: Sha -> GoodCommits -> Bool
+checkGoodCommit sha (GoodCommits s) = S.member sha s
+
+addGoodCommits :: [Sha] -> GoodCommits -> GoodCommits
+addGoodCommits shas (GoodCommits s) = GoodCommits $
+ S.union s (S.fromList shas)
+
+displayList :: [String] -> String -> IO ()
+displayList items header
+ | null items = return ()
+ | otherwise = do
+ putStrLn header
+ putStr $ unlines $ map (\i -> "\t" ++ i) truncateditems
+ where
+ numitems = length items
+ truncateditems
+ | numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"]
+ | otherwise = items
+
+{- Fix problems that would prevent repair from working at all
+ -
+ - A missing or corrupt .git/HEAD makes git not treat the repository as a
+ - git repo. If there is a git repo in a parent directory, it may move up
+ - the tree and use that one instead. So, cannot use `git show-ref HEAD` to
+ - test it.
+ -
+ - Explode the packed refs file, to simplify dealing with refs, and because
+ - fsck can complain about bad refs in it.
+ -}
+preRepair :: Repo -> IO ()
+preRepair g = do
+ unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
+ nukeFile headfile
+ writeFile headfile "ref: refs/heads/master"
+ explodePackedRefsFile g
+ unless (repoIsLocalBare g) $ do
+ let f = indexFile g
+ void $ tryIO $ allowWrite f
+ where
+ headfile = localGitDir g </> "HEAD"
+ validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
+
+{- Put it all together. -}
+runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair forced g = do
+ preRepair g
+ putStrLn "Running git fsck ..."
+ fsckresult <- findBroken False g
+ if foundBroken fsckresult
+ then runRepair' fsckresult forced Nothing g
+ else do
+ putStrLn "No problems found."
+ return (True, S.empty, [])
+
+runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepairOf fsckresult forced referencerepo g = do
+ preRepair g
+ runRepair' fsckresult forced referencerepo g
+
+runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair' fsckresult forced referencerepo g = do
+ missing <- cleanCorruptObjects fsckresult g
+ stillmissing <- retrieveMissingObjects missing referencerepo g
+ case stillmissing of
+ FsckFoundMissing s
+ | S.null s -> if repoIsLocalBare g
+ then successfulfinish S.empty []
+ else ifM (checkIndex S.empty g)
+ ( successfulfinish s []
+ , do
+ putStrLn "No missing objects found, but the index file is corrupt!"
+ if forced
+ then corruptedindex
+ else needforce S.empty
+ )
+ | otherwise -> if forced
+ then ifM (checkIndex s g)
+ ( continuerepairs s
+ , corruptedindex
+ )
+ else do
+ putStrLn $ unwords
+ [ show (S.size s)
+ , "missing objects could not be recovered!"
+ ]
+ unsuccessfulfinish s
+ FsckFailed
+ | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g)
+ ( do
+ missing' <- cleanCorruptObjects FsckFailed g
+ case missing' of
+ FsckFailed -> return (False, S.empty, [])
+ FsckFoundMissing stillmissing' -> continuerepairs stillmissing'
+ , corruptedindex
+ )
+ | otherwise -> unsuccessfulfinish S.empty
+ where
+ continuerepairs stillmissing = do
+ (remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g
+ unless (null remotebranches) $
+ putStrLn $ unwords
+ [ "Removed"
+ , show (length remotebranches)
+ , "remote tracking branches that referred to missing objects."
+ ]
+ (resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g
+ displayList (map show resetbranches)
+ "Reset these local branches to old versions before the missing objects were committed:"
+ displayList (map show deletedbranches)
+ "Deleted these local branches, which could not be recovered due to missing objects:"
+ deindexedfiles <- rewriteIndex stillmissing g
+ displayList deindexedfiles
+ "Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate."
+ let modifiedbranches = resetbranches ++ deletedbranches
+ if null resetbranches && null deletedbranches
+ then successfulfinish stillmissing modifiedbranches
+ else do
+ unless (repoIsLocalBare g) $ do
+ mcurr <- Branch.currentUnsafe g
+ case mcurr of
+ Nothing -> return ()
+ Just curr -> when (any (== curr) modifiedbranches) $ do
+ putStrLn $ unwords
+ [ "You currently have"
+ , show curr
+ , "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"
+ ]
+ putStrLn "Successfully recovered repository!"
+ putStrLn "Please carefully check that the changes mentioned above are ok.."
+ return (True, stillmissing, modifiedbranches)
+
+ corruptedindex = do
+ nukeFile (indexFile g)
+ -- The corrupted index can prevent fsck from finding other
+ -- problems, so re-run repair.
+ fsckresult' <- findBroken False g
+ result <- runRepairOf fsckresult' forced referencerepo g
+ putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."
+ return result
+
+ successfulfinish stillmissing modifiedbranches = do
+ mapM_ putStrLn
+ [ "Successfully recovered repository!"
+ , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok."
+ ]
+ return (True, stillmissing, modifiedbranches)
+ unsuccessfulfinish stillmissing = do
+ if repoIsLocalBare g
+ then do
+ putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry."
+ putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state."
+ return (False, stillmissing, [])
+ else needforce stillmissing
+ needforce stillmissing = do
+ putStrLn "To force a recovery to a usable state, retry with the --force parameter."
+ return (False, stillmissing, [])
+
+successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool
+successfulRepair = fst3
+
+safeReadFile :: FilePath -> IO String
+safeReadFile f = do
+ allowRead f
+ readFileStrictAnyEncoding f
diff --git a/Git/Sha.hs b/Git/Sha.hs
new file mode 100644
index 0000000..ee1b6d6
--- /dev/null
+++ b/Git/Sha.hs
@@ -0,0 +1,39 @@
+{- git SHA stuff
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Sha where
+
+import Common
+import Git.Types
+
+{- Runs an action that causes a git subcommand to emit a Sha, and strips
+ - any trailing newline, returning the sha. -}
+getSha :: String -> IO String -> IO Sha
+getSha subcommand a = maybe bad return =<< extractSha <$> a
+ where
+ bad = error $ "failed to read sha from git " ++ subcommand
+
+{- Extracts the Sha from a string. There can be a trailing newline after
+ - it, but nothing else. -}
+extractSha :: String -> Maybe Sha
+extractSha s
+ | len == shaSize = val s
+ | len == shaSize + 1 && length s' == shaSize = val s'
+ | otherwise = Nothing
+ where
+ len = length s
+ s' = firstLine s
+ val v
+ | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
+ | otherwise = Nothing
+
+{- Size of a git sha. -}
+shaSize :: Int
+shaSize = 40
+
+nullSha :: Ref
+nullSha = Ref $ replicate shaSize '0'
diff --git a/Git/Types.hs b/Git/Types.hs
new file mode 100644
index 0000000..e63e930
--- /dev/null
+++ b/Git/Types.hs
@@ -0,0 +1,95 @@
+{- git data types
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Types where
+
+import Network.URI
+import qualified Data.Map as M
+import System.Posix.Types
+import Utility.SafeCommand
+
+{- Support repositories on local disk, and repositories accessed via an URL.
+ -
+ - Repos on local disk have a git directory, and unless bare, a worktree.
+ -
+ - A local repo may not have had its config read yet, in which case all
+ - that's known about it is its path.
+ -
+ - Finally, an Unknown repository may be known to exist, but nothing
+ - else known about it.
+ -}
+data RepoLocation
+ = Local { gitdir :: FilePath, worktree :: Maybe FilePath }
+ | LocalUnknown FilePath
+ | Url URI
+ | Unknown
+ deriving (Show, Eq)
+
+data Repo = Repo
+ { location :: RepoLocation
+ , config :: M.Map String String
+ -- 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
+ , remoteName :: Maybe RemoteName
+ -- alternate environment to use when running git commands
+ , gitEnv :: Maybe [(String, String)]
+ -- global options to pass to git when running git commands
+ , gitGlobalOpts :: [CommandParam]
+ } deriving (Show, Eq)
+
+type RemoteName = String
+
+{- A git ref. Can be a sha1, or a branch or tag name. -}
+newtype Ref = Ref String
+ deriving (Eq, Ord)
+
+instance Show Ref where
+ show (Ref v) = v
+
+{- Aliases for Ref. -}
+type Branch = Ref
+type Sha = Ref
+type Tag = Ref
+
+{- 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 "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
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
new file mode 100644
index 0000000..3b33ac8
--- /dev/null
+++ b/Git/UpdateIndex.hs
@@ -0,0 +1,86 @@
+{- git-update-index library
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns, CPP #-}
+
+module Git.UpdateIndex (
+ Streamer,
+ pureStreamer,
+ streamUpdateIndex,
+ lsTree,
+ updateIndexLine,
+ stageFile,
+ unstageFile,
+ stageSymlink
+) where
+
+import Common
+import Git
+import Git.Types
+import Git.Command
+import Git.FilePath
+import Git.Sha
+
+{- 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 ()
+
+{- A streamer with a precalculated value. -}
+pureStreamer :: String -> Streamer
+pureStreamer !s = \streamer -> streamer s
+
+{- Streams content into update-index from a list of Streamers. -}
+streamUpdateIndex :: Repo -> [Streamer] -> IO ()
+streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
+ fileEncoding h
+ forM_ as (stream h)
+ hClose h
+ where
+ params = map Param ["update-index", "-z", "--index-info"]
+ stream h a = a (streamer h)
+ streamer h s = do
+ hPutStr h s
+ hPutStr h "\0"
+
+{- A streamer that adds the current tree for a ref. Useful for eg, copying
+ - and modifying branches. -}
+lsTree :: Ref -> Repo -> Streamer
+lsTree (Ref x) repo streamer = do
+ (s, cleanup) <- pipeNullSplit params repo
+ mapM_ streamer s
+ void $ cleanup
+ where
+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
+
+{- 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 " ++ show 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
+
+{- A streamer that removes a file from the index. -}
+unstageFile :: FilePath -> Repo -> IO Streamer
+unstageFile file repo = do
+ p <- toTopFilePath file repo
+ return $ pureStreamer $ "0 " ++ show 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
+ return $ pureStreamer line
+
+indexPath :: TopFilePath -> InternalGitPath
+indexPath = toInternalGitPath . getTopFilePath
diff --git a/Git/Url.hs b/Git/Url.hs
new file mode 100644
index 0000000..d383a6a
--- /dev/null
+++ b/Git/Url.hs
@@ -0,0 +1,71 @@
+{- git repository urls
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Url (
+ scheme,
+ host,
+ port,
+ hostuser,
+ authority,
+) where
+
+import Network.URI hiding (scheme, authority)
+
+import Common
+import Git.Types
+import Git
+
+{- Scheme of an URL repo. -}
+scheme :: Repo -> String
+scheme Repo { location = Url u } = uriScheme u
+scheme repo = notUrl repo
+
+{- Work around a bug in the real uriRegName
+ - <http://trac.haskell.org/network/ticket/40> -}
+uriRegName' :: URIAuth -> String
+uriRegName' a = fixup $ uriRegName a
+ where
+ fixup x@('[':rest)
+ | rest !! len == ']' = take len rest
+ | otherwise = x
+ where
+ len = length rest - 1
+ fixup x = x
+
+{- Hostname of an URL repo. -}
+host :: Repo -> Maybe String
+host = authpart uriRegName'
+
+{- Port of an URL repo, if it has a nonstandard one. -}
+port :: Repo -> Maybe Integer
+port r =
+ case authpart uriPort r of
+ Nothing -> Nothing
+ Just ":" -> Nothing
+ Just (':':p) -> readish p
+ Just _ -> Nothing
+
+{- Hostname of an URL repo, including any username (ie, "user@host") -}
+hostuser :: Repo -> Maybe String
+hostuser r = (++)
+ <$> authpart uriUserInfo r
+ <*> authpart uriRegName' r
+
+{- The full authority portion an URL repo. (ie, "user@host:port") -}
+authority :: Repo -> Maybe String
+authority = authpart assemble
+ where
+ assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
+
+{- Applies a function to extract part of the uriAuthority of an URL repo. -}
+authpart :: (URIAuth -> a) -> Repo -> Maybe a
+authpart a Repo { location = Url u } = a <$> uriAuthority u
+authpart _ 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
new file mode 100644
index 0000000..5ad1d59
--- /dev/null
+++ b/Git/Version.hs
@@ -0,0 +1,43 @@
+{- git versions
+ -
+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Version where
+
+import Common
+
+data GitVersion = GitVersion String Integer
+ deriving (Eq)
+
+instance Ord GitVersion where
+ compare (GitVersion _ x) (GitVersion _ y) = compare x y
+
+instance Show GitVersion where
+ show (GitVersion s _) = s
+
+installed :: IO GitVersion
+installed = normalize . extract <$> readProcess "git" ["--version"]
+ where
+ extract s = case lines s of
+ [] -> ""
+ (l:_) -> unwords $ drop 2 $ words l
+
+{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
+ - a somewhat arbitrary integer representation. -}
+normalize :: String -> GitVersion
+normalize v = GitVersion v $
+ sum $ mult 1 $ reverse $ extend precision $ take precision $
+ map readi $ split "." v
+ where
+ extend n l = l ++ replicate (n - length l) 0
+ mult _ [] = []
+ mult n (x:xs) = (n*x) : mult (n*10^width) xs
+ readi :: String -> Integer
+ readi s = case reads s of
+ ((x,_):_) -> x
+ _ -> 0
+ precision = 10 -- number of segments of the version to compare
+ width = length "yyyymmddhhmmss" -- maximum width of a segment
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-27 13:46:39 +0000