convert GitRepo to qualified import
This commit is contained in:
Joey Hess
parent
eda80e44c5
commit
48643b68b3
11 changed files with 173 additions and 189 deletions
158
GitRepo.hs
158
GitRepo.hs
|
|
@ -3,27 +3,27 @@
|
|||
- This is written to be completely independant of git-annex and should be
|
||||
- suitable for other uses.
|
||||
-
|
||||
- -}
|
||||
-}
|
||||
|
||||
module GitRepo (
|
||||
GitRepo,
|
||||
gitRepoFromCwd,
|
||||
gitRepoFromPath,
|
||||
gitRepoFromUrl,
|
||||
gitRepoIsLocal,
|
||||
gitRepoIsRemote,
|
||||
gitRepoDescribe,
|
||||
gitWorkTree,
|
||||
gitDir,
|
||||
gitRelative,
|
||||
gitConfig,
|
||||
gitConfigMap,
|
||||
gitConfigRead,
|
||||
gitRun,
|
||||
gitAttributes,
|
||||
gitRepoRemotes,
|
||||
gitRepoRemotesAdd,
|
||||
gitRepoRemoteName
|
||||
Repo,
|
||||
repoFromCwd,
|
||||
repoFromPath,
|
||||
repoFromUrl,
|
||||
repoIsLocal,
|
||||
repoIsRemote,
|
||||
repoDescribe,
|
||||
workTree,
|
||||
dir,
|
||||
relative,
|
||||
configGet,
|
||||
configMap,
|
||||
configRead,
|
||||
run,
|
||||
attributes,
|
||||
remotes,
|
||||
remotesAdd,
|
||||
repoRemoteName
|
||||
) where
|
||||
|
||||
import Directory
|
||||
|
|
@ -44,35 +44,35 @@ import Utility
|
|||
{- A git repository can be on local disk or remote. Not to be confused
|
||||
- with a git repo's configured remotes, some of which may be on local
|
||||
- disk. -}
|
||||
data GitRepo =
|
||||
LocalGitRepo {
|
||||
data Repo =
|
||||
LocalRepo {
|
||||
top :: FilePath,
|
||||
config :: Map String String,
|
||||
remotes :: [GitRepo],
|
||||
remotes :: [Repo],
|
||||
-- remoteName holds the name used for this repo in remotes
|
||||
remoteName :: Maybe String
|
||||
} | RemoteGitRepo {
|
||||
} | RemoteRepo {
|
||||
url :: String,
|
||||
top :: FilePath,
|
||||
config :: Map String String,
|
||||
remotes :: [GitRepo],
|
||||
remotes :: [Repo],
|
||||
remoteName :: Maybe String
|
||||
} deriving (Show, Read, Eq)
|
||||
|
||||
{- Local GitRepo constructor. -}
|
||||
gitRepoFromPath :: FilePath -> GitRepo
|
||||
gitRepoFromPath dir =
|
||||
LocalGitRepo {
|
||||
{- Local Repo constructor. -}
|
||||
repoFromPath :: FilePath -> Repo
|
||||
repoFromPath dir =
|
||||
LocalRepo {
|
||||
top = dir,
|
||||
config = Map.empty,
|
||||
remotes = [],
|
||||
remoteName = Nothing
|
||||
}
|
||||
|
||||
{- Remote GitRepo constructor. Throws exception on invalid url. -}
|
||||
gitRepoFromUrl :: String -> GitRepo
|
||||
gitRepoFromUrl url =
|
||||
RemoteGitRepo {
|
||||
{- Remote Repo constructor. Throws exception on invalid url. -}
|
||||
repoFromUrl :: String -> Repo
|
||||
repoFromUrl url =
|
||||
RemoteRepo {
|
||||
url = url,
|
||||
top = path url,
|
||||
config = Map.empty,
|
||||
|
|
@ -82,72 +82,68 @@ gitRepoFromUrl url =
|
|||
where path url = uriPath $ fromJust $ parseURI url
|
||||
|
||||
{- User-visible description of a git repo. -}
|
||||
gitRepoDescribe repo =
|
||||
repoDescribe repo =
|
||||
if (isJust $ remoteName repo)
|
||||
then fromJust $ remoteName repo
|
||||
else if (gitRepoIsLocal repo)
|
||||
else if (repoIsLocal repo)
|
||||
then top repo
|
||||
else url repo
|
||||
|
||||
{- Returns the list of a repo's remotes. -}
|
||||
gitRepoRemotes :: GitRepo -> [GitRepo]
|
||||
gitRepoRemotes r = remotes r
|
||||
|
||||
{- Constructs and returns an updated version of a repo with
|
||||
- different remotes list. -}
|
||||
gitRepoRemotesAdd :: GitRepo -> [GitRepo] -> GitRepo
|
||||
gitRepoRemotesAdd repo rs = repo { remotes = rs }
|
||||
remotesAdd :: Repo -> [Repo] -> Repo
|
||||
remotesAdd repo rs = repo { remotes = rs }
|
||||
|
||||
{- Returns the name of the remote that corresponds to the repo, if
|
||||
- it is a remote. Otherwise, "" -}
|
||||
gitRepoRemoteName r =
|
||||
repoRemoteName r =
|
||||
if (isJust $ remoteName r)
|
||||
then fromJust $ remoteName r
|
||||
else ""
|
||||
|
||||
{- Some code needs to vary between remote and local repos, or bare and
|
||||
- non-bare, these functions help with that. -}
|
||||
gitRepoIsLocal repo = case (repo) of
|
||||
LocalGitRepo {} -> True
|
||||
RemoteGitRepo {} -> False
|
||||
gitRepoIsRemote repo = not $ gitRepoIsLocal repo
|
||||
repoIsLocal repo = case (repo) of
|
||||
LocalRepo {} -> True
|
||||
RemoteRepo {} -> False
|
||||
repoIsRemote repo = not $ repoIsLocal repo
|
||||
assertlocal repo action =
|
||||
if (gitRepoIsLocal repo)
|
||||
if (repoIsLocal repo)
|
||||
then action
|
||||
else error $ "acting on remote git repo " ++ (gitRepoDescribe repo) ++
|
||||
else error $ "acting on remote git repo " ++ (repoDescribe repo) ++
|
||||
" not supported"
|
||||
bare :: GitRepo -> Bool
|
||||
bare :: Repo -> Bool
|
||||
bare repo =
|
||||
if (member b (config repo))
|
||||
then ("true" == fromJust (Map.lookup b (config repo)))
|
||||
else error $ "it is not known if git repo " ++ (gitRepoDescribe repo) ++
|
||||
else error $ "it is not known if git repo " ++ (repoDescribe repo) ++
|
||||
" is a bare repository; config not read"
|
||||
where
|
||||
b = "core.bare"
|
||||
|
||||
{- Path to a repository's gitattributes file. -}
|
||||
gitAttributes :: GitRepo -> String
|
||||
gitAttributes repo = assertlocal repo $ do
|
||||
attributes :: Repo -> String
|
||||
attributes repo = assertlocal repo $ do
|
||||
if (bare repo)
|
||||
then (top repo) ++ "/info/.gitattributes"
|
||||
else (top repo) ++ "/.gitattributes"
|
||||
|
||||
{- Path to a repository's .git directory, relative to its topdir. -}
|
||||
gitDir :: GitRepo -> String
|
||||
gitDir repo = assertlocal repo $
|
||||
dir :: Repo -> String
|
||||
dir repo = assertlocal repo $
|
||||
if (bare repo)
|
||||
then ""
|
||||
else ".git"
|
||||
|
||||
{- Path to a repository's --work-tree. -}
|
||||
gitWorkTree :: GitRepo -> FilePath
|
||||
gitWorkTree repo = top repo
|
||||
workTree :: Repo -> FilePath
|
||||
workTree repo = top repo
|
||||
|
||||
{- Given a relative or absolute filename in a repository, calculates the
|
||||
- name to use to refer to the file relative to a git repository's top.
|
||||
- This is the same form displayed and used by git. -}
|
||||
gitRelative :: GitRepo -> String -> String
|
||||
gitRelative repo file = drop (length absrepo) absfile
|
||||
relative :: Repo -> String -> String
|
||||
relative repo file = drop (length absrepo) absfile
|
||||
where
|
||||
-- normalize both repo and file, so that repo
|
||||
-- will be substring of file
|
||||
|
|
@ -159,27 +155,27 @@ gitRelative repo file = drop (length absrepo) absfile
|
|||
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
|
||||
|
||||
{- Constructs a git command line operating on the specified repo. -}
|
||||
gitCommandLine :: GitRepo -> [String] -> [String]
|
||||
gitCommandLine :: Repo -> [String] -> [String]
|
||||
gitCommandLine repo params = assertlocal repo $
|
||||
-- force use of specified repo via --git-dir and --work-tree
|
||||
["--git-dir="++(top repo)++"/"++(gitDir repo), "--work-tree="++(top repo)] ++ params
|
||||
["--git-dir="++(top repo)++"/"++(dir repo), "--work-tree="++(top repo)] ++ params
|
||||
|
||||
{- Runs git in the specified repo. -}
|
||||
gitRun :: GitRepo -> [String] -> IO ()
|
||||
gitRun repo params = assertlocal repo $ do
|
||||
run :: Repo -> [String] -> IO ()
|
||||
run repo params = assertlocal repo $ do
|
||||
r <- rawSystem "git" (gitCommandLine repo params)
|
||||
return ()
|
||||
|
||||
{- Runs a git subcommand and returns its output. -}
|
||||
gitPipeRead :: GitRepo -> [String] -> IO String
|
||||
gitPipeRead :: Repo -> [String] -> IO String
|
||||
gitPipeRead repo params = assertlocal repo $ do
|
||||
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
|
||||
ret <- hGetContentsStrict h
|
||||
return ret
|
||||
|
||||
{- Runs git config and populates a repo with its config. -}
|
||||
gitConfigRead :: GitRepo -> IO GitRepo
|
||||
gitConfigRead repo = assertlocal repo $ do
|
||||
configRead :: Repo -> IO Repo
|
||||
configRead repo = assertlocal repo $ do
|
||||
{- Cannot use gitPipeRead because it relies on the config having
|
||||
been already read. Instead, chdir to the repo. -}
|
||||
cwd <- getCurrentDirectory
|
||||
|
|
@ -187,12 +183,12 @@ gitConfigRead repo = assertlocal repo $ do
|
|||
(\_ -> changeWorkingDirectory cwd) $
|
||||
pOpen ReadFromPipe "git" ["config", "--list"] $ \h -> do
|
||||
val <- hGetContentsStrict h
|
||||
let r = repo { config = gitConfigParse val }
|
||||
return r { remotes = gitConfigRemotes r }
|
||||
let r = repo { config = configParse val }
|
||||
return r { remotes = configRemotes r }
|
||||
|
||||
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
|
||||
gitConfigRemotes :: GitRepo -> [GitRepo]
|
||||
gitConfigRemotes repo = map construct remotes
|
||||
configRemotes :: Repo -> [Repo]
|
||||
configRemotes repo = map construct remotes
|
||||
where
|
||||
remotes = toList $ filter $ config repo
|
||||
filter = filterWithKey (\k _ -> isremote k)
|
||||
|
|
@ -200,12 +196,12 @@ gitConfigRemotes repo = map construct remotes
|
|||
remotename k = (split "." k) !! 1
|
||||
construct (k,v) = (gen v) { remoteName = Just $ remotename k }
|
||||
gen v = if (isURI v)
|
||||
then gitRepoFromUrl v
|
||||
else gitRepoFromPath v
|
||||
then repoFromUrl v
|
||||
else repoFromPath v
|
||||
|
||||
{- Parses git config --list output into a config map. -}
|
||||
gitConfigParse :: String -> Map.Map String String
|
||||
gitConfigParse s = Map.fromList $ map pair $ lines s
|
||||
configParse :: String -> Map.Map String String
|
||||
configParse s = Map.fromList $ map pair $ lines s
|
||||
where
|
||||
pair l = (key l, val l)
|
||||
key l = (keyval l) !! 0
|
||||
|
|
@ -214,21 +210,21 @@ gitConfigParse s = Map.fromList $ map pair $ lines s
|
|||
sep = "="
|
||||
|
||||
{- Returns a single git config setting, or a default value if not set. -}
|
||||
gitConfig :: GitRepo -> String -> String -> String
|
||||
gitConfig repo key defaultValue =
|
||||
configGet :: Repo -> String -> String -> String
|
||||
configGet repo key defaultValue =
|
||||
Map.findWithDefault defaultValue key (config repo)
|
||||
|
||||
{- Access to raw config Map -}
|
||||
gitConfigMap :: GitRepo -> Map String String
|
||||
gitConfigMap repo = config repo
|
||||
configMap :: Repo -> Map String String
|
||||
configMap repo = config repo
|
||||
|
||||
{- Finds the current git repository, which may be in a parent directory. -}
|
||||
gitRepoFromCwd :: IO GitRepo
|
||||
gitRepoFromCwd = do
|
||||
repoFromCwd :: IO Repo
|
||||
repoFromCwd = do
|
||||
cwd <- getCurrentDirectory
|
||||
top <- seekUp cwd isRepoTop
|
||||
case top of
|
||||
(Just dir) -> return $ gitRepoFromPath dir
|
||||
(Just dir) -> return $ repoFromPath dir
|
||||
Nothing -> error "Not in a git repository."
|
||||
|
||||
seekUp :: String -> (String -> IO Bool) -> IO (Maybe String)
|
||||
|
|
@ -241,11 +237,11 @@ seekUp dir want = do
|
|||
d -> seekUp d want
|
||||
|
||||
isRepoTop dir = do
|
||||
r <- isGitRepo dir
|
||||
r <- isRepo dir
|
||||
b <- isBareRepo dir
|
||||
return (r || b)
|
||||
where
|
||||
isGitRepo dir = gitSignature dir ".git" ".git/config"
|
||||
isRepo dir = gitSignature dir ".git" ".git/config"
|
||||
isBareRepo dir = gitSignature dir "objects" "config"
|
||||
gitSignature dir subdir file = do
|
||||
s <- (doesDirectoryExist (dir ++ "/" ++ subdir))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue