fix remote vs remote wording confusion
This commit is contained in:
parent
897bf49b4e
commit
46ac66a438
1 changed files with 27 additions and 29 deletions
54
GitRepo.hs
54
GitRepo.hs
|
@ -10,8 +10,7 @@ module GitRepo (
|
||||||
repoFromCwd,
|
repoFromCwd,
|
||||||
repoFromPath,
|
repoFromPath,
|
||||||
repoFromUrl,
|
repoFromUrl,
|
||||||
repoIsLocal,
|
repoIsUrl,
|
||||||
repoIsRemote,
|
|
||||||
repoIsSsh,
|
repoIsSsh,
|
||||||
repoDescribe,
|
repoDescribe,
|
||||||
workTree,
|
workTree,
|
||||||
|
@ -46,17 +45,16 @@ import Maybe
|
||||||
|
|
||||||
import Utility
|
import Utility
|
||||||
|
|
||||||
{- A git repository can be on local disk or remote. Not to be confused
|
{- There are two types of repositories; those on local disk and those
|
||||||
- with a git repo's configured remotes, some of which may be on local
|
- accessed via an URL. -}
|
||||||
- disk. -}
|
|
||||||
data Repo =
|
data Repo =
|
||||||
LocalRepo {
|
Repo {
|
||||||
top :: FilePath,
|
top :: FilePath,
|
||||||
config :: Map String String,
|
config :: Map String String,
|
||||||
remotes :: [Repo],
|
remotes :: [Repo],
|
||||||
-- remoteName holds the name used for this repo in remotes
|
-- remoteName holds the name used for this repo in remotes
|
||||||
remoteName :: Maybe String
|
remoteName :: Maybe String
|
||||||
} | RemoteRepo {
|
} | UrlRepo {
|
||||||
url :: URI,
|
url :: URI,
|
||||||
config :: Map String String,
|
config :: Map String String,
|
||||||
remotes :: [Repo],
|
remotes :: [Repo],
|
||||||
|
@ -66,7 +64,7 @@ data Repo =
|
||||||
{- Local Repo constructor. -}
|
{- Local Repo constructor. -}
|
||||||
repoFromPath :: FilePath -> Repo
|
repoFromPath :: FilePath -> Repo
|
||||||
repoFromPath dir =
|
repoFromPath dir =
|
||||||
LocalRepo {
|
Repo {
|
||||||
top = dir,
|
top = dir,
|
||||||
config = Map.empty,
|
config = Map.empty,
|
||||||
remotes = [],
|
remotes = [],
|
||||||
|
@ -76,7 +74,7 @@ repoFromPath dir =
|
||||||
{- Remote Repo constructor. Throws exception on invalid url. -}
|
{- Remote Repo constructor. Throws exception on invalid url. -}
|
||||||
repoFromUrl :: String -> Repo
|
repoFromUrl :: String -> Repo
|
||||||
repoFromUrl url =
|
repoFromUrl url =
|
||||||
RemoteRepo {
|
UrlRepo {
|
||||||
url = fromJust $ parseURI url,
|
url = fromJust $ parseURI url,
|
||||||
config = Map.empty,
|
config = Map.empty,
|
||||||
remotes = [],
|
remotes = [],
|
||||||
|
@ -87,7 +85,7 @@ repoFromUrl url =
|
||||||
repoDescribe repo =
|
repoDescribe repo =
|
||||||
if (isJust $ remoteName repo)
|
if (isJust $ remoteName repo)
|
||||||
then fromJust $ remoteName repo
|
then fromJust $ remoteName repo
|
||||||
else if (repoIsLocal repo)
|
else if (not $ repoIsUrl repo)
|
||||||
then top repo
|
then top repo
|
||||||
else show (url repo)
|
else show (url repo)
|
||||||
|
|
||||||
|
@ -103,20 +101,19 @@ repoRemoteName r =
|
||||||
then fromJust $ remoteName r
|
then fromJust $ remoteName r
|
||||||
else ""
|
else ""
|
||||||
|
|
||||||
{- Some code needs to vary between remote and local repos,
|
{- Some code needs to vary between URL and normal repos,
|
||||||
- or bare and non-bare, these functions help with that. -}
|
- or bare and non-bare, these functions help with that. -}
|
||||||
repoIsLocal repo = case (repo) of
|
repoIsUrl repo = case (repo) of
|
||||||
LocalRepo {} -> True
|
UrlRepo {} -> True
|
||||||
RemoteRepo {} -> False
|
Repo {} -> False
|
||||||
repoIsRemote repo = not $ repoIsLocal repo
|
repoIsSsh repo = repoIsUrl repo && (uriScheme $ url repo) == "ssh:"
|
||||||
repoIsSsh repo = repoIsRemote repo && (uriScheme $ url repo) == "ssh:"
|
assertLocal repo action =
|
||||||
assertlocal repo action =
|
if (not $ repoIsUrl repo)
|
||||||
if (repoIsLocal repo)
|
|
||||||
then action
|
then action
|
||||||
else error $ "acting on remote git repo " ++ (repoDescribe repo) ++
|
else error $ "acting on remote git repo " ++ (repoDescribe repo) ++
|
||||||
" not supported"
|
" not supported"
|
||||||
assertremote repo action =
|
assertUrl repo action =
|
||||||
if (repoIsRemote repo)
|
if (repoIsUrl repo)
|
||||||
then action
|
then action
|
||||||
else error $ "acting on local git repo " ++ (repoDescribe repo) ++
|
else error $ "acting on local git repo " ++ (repoDescribe repo) ++
|
||||||
" not supported"
|
" not supported"
|
||||||
|
@ -135,7 +132,7 @@ bare repo =
|
||||||
|
|
||||||
{- Path to a repository's gitattributes file. -}
|
{- Path to a repository's gitattributes file. -}
|
||||||
attributes :: Repo -> String
|
attributes :: Repo -> String
|
||||||
attributes repo = assertlocal repo $ do
|
attributes repo = assertLocal repo $ do
|
||||||
if (bare repo)
|
if (bare repo)
|
||||||
then (top repo) ++ "/info/.gitattributes"
|
then (top repo) ++ "/info/.gitattributes"
|
||||||
else (top repo) ++ "/.gitattributes"
|
else (top repo) ++ "/.gitattributes"
|
||||||
|
@ -147,13 +144,13 @@ dir repo = if (bare repo) then "" else ".git"
|
||||||
{- Path to a repository's --work-tree. -}
|
{- Path to a repository's --work-tree. -}
|
||||||
workTree :: Repo -> FilePath
|
workTree :: Repo -> FilePath
|
||||||
workTree repo =
|
workTree repo =
|
||||||
if (repoIsLocal) repo
|
if (not $ repoIsUrl repo)
|
||||||
then top repo
|
then top repo
|
||||||
else assertssh repo $ (remoteHost repo) ++ ":" ++ (uriPath $ url repo)
|
else assertssh repo $ (remoteHost repo) ++ ":" ++ (uriPath $ url repo)
|
||||||
|
|
||||||
{- Hostname for a remote repo. (May include a username and/or port too.) -}
|
{- Hostname for a remote repo. (May include a username and/or port too.) -}
|
||||||
remoteHost :: Repo -> String
|
remoteHost :: Repo -> String
|
||||||
remoteHost repo = assertremote repo $
|
remoteHost repo = assertUrl repo $
|
||||||
(uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
|
(uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
|
||||||
where
|
where
|
||||||
a = fromJust $ uriAuthority $ url repo
|
a = fromJust $ uriAuthority $ url repo
|
||||||
|
@ -175,19 +172,19 @@ relative repo file = drop (length absrepo) absfile
|
||||||
|
|
||||||
{- Constructs a git command line operating on the specified repo. -}
|
{- Constructs a git command line operating on the specified repo. -}
|
||||||
gitCommandLine :: Repo -> [String] -> [String]
|
gitCommandLine :: Repo -> [String] -> [String]
|
||||||
gitCommandLine repo params = assertlocal repo $
|
gitCommandLine repo params = assertLocal repo $
|
||||||
-- force use of specified repo via --git-dir and --work-tree
|
-- force use of specified repo via --git-dir and --work-tree
|
||||||
["--git-dir="++(top repo)++"/"++(dir repo), "--work-tree="++(top repo)] ++ params
|
["--git-dir="++(top repo)++"/"++(dir repo), "--work-tree="++(top repo)] ++ params
|
||||||
|
|
||||||
{- Runs git in the specified repo. -}
|
{- Runs git in the specified repo. -}
|
||||||
run :: Repo -> [String] -> IO ()
|
run :: Repo -> [String] -> IO ()
|
||||||
run repo params = assertlocal repo $ do
|
run repo params = assertLocal repo $ do
|
||||||
r <- safeSystem "git" (gitCommandLine repo params)
|
r <- safeSystem "git" (gitCommandLine repo params)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
{- Runs a git subcommand and returns its output. -}
|
{- Runs a git subcommand and returns its output. -}
|
||||||
pipeRead :: Repo -> [String] -> IO String
|
pipeRead :: Repo -> [String] -> IO String
|
||||||
pipeRead repo params = assertlocal repo $ do
|
pipeRead repo params = assertLocal repo $ do
|
||||||
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
|
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
|
||||||
ret <- hGetContentsStrict h
|
ret <- hGetContentsStrict h
|
||||||
return ret
|
return ret
|
||||||
|
@ -208,10 +205,11 @@ notInRepo repo location = do
|
||||||
|
|
||||||
{- Runs git config and populates a repo with its config. -}
|
{- Runs git config and populates a repo with its config. -}
|
||||||
configRead :: Repo -> IO Repo
|
configRead :: Repo -> IO Repo
|
||||||
configRead repo = if (repoIsLocal repo)
|
configRead repo =
|
||||||
|
if (not $ repoIsUrl repo)
|
||||||
|
then do
|
||||||
{- Cannot use pipeRead because it relies on the config having
|
{- Cannot use pipeRead because it relies on the config having
|
||||||
been already read. Instead, chdir to the repo. -}
|
been already read. Instead, chdir to the repo. -}
|
||||||
then do
|
|
||||||
cwd <- getCurrentDirectory
|
cwd <- getCurrentDirectory
|
||||||
bracket_ (changeWorkingDirectory (top repo))
|
bracket_ (changeWorkingDirectory (top repo))
|
||||||
(\_ -> changeWorkingDirectory cwd) $
|
(\_ -> changeWorkingDirectory cwd) $
|
||||||
|
|
Loading…
Reference in a new issue