improve GitRepos functions for pulling apart URL to repo
This commit is contained in:
parent
5c4f90b2d0
commit
acde7a1736
3 changed files with 36 additions and 18 deletions
|
@ -161,7 +161,7 @@ absRepo reference r
|
|||
{- Checks if two repos are the same. -}
|
||||
same :: Git.Repo -> Git.Repo -> Bool
|
||||
same a b
|
||||
| both Git.repoIsSsh = matching Git.urlHostFull && matching Git.workTree
|
||||
| both Git.repoIsSsh = matching Git.urlAuthority && matching Git.workTree
|
||||
| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
|
||||
| neither Git.repoIsSsh = matching Git.workTree
|
||||
| otherwise = False
|
||||
|
@ -210,7 +210,7 @@ tryScan r
|
|||
"git config --list"
|
||||
liftIO $ pipedconfig "ssh" $ map Param $
|
||||
words sshoptions ++
|
||||
[Git.urlHostFull r, sshcmd]
|
||||
[Git.urlAuthority r, sshcmd]
|
||||
|
||||
-- First, try sshing and running git config manually,
|
||||
-- only fall back to git-annex-shell configlist if that
|
||||
|
|
48
GitRepo.hs
48
GitRepo.hs
|
@ -24,7 +24,9 @@ module GitRepo (
|
|||
relative,
|
||||
urlPath,
|
||||
urlHost,
|
||||
urlHostFull,
|
||||
urlPort,
|
||||
urlHostUser,
|
||||
urlAuthority,
|
||||
urlScheme,
|
||||
configGet,
|
||||
configMap,
|
||||
|
@ -131,7 +133,7 @@ localToUrl reference r
|
|||
where
|
||||
absurl =
|
||||
urlScheme reference ++ "//" ++
|
||||
urlHostFull reference ++
|
||||
urlAuthority reference ++
|
||||
workTree r
|
||||
|
||||
{- User-visible description of a git repo. -}
|
||||
|
@ -235,29 +237,45 @@ relative repo@(Repo { location = Dir d }) file = do
|
|||
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
|
||||
relative repo _ = assertLocal repo $ error "internal"
|
||||
|
||||
{- Path of an URL repo. -}
|
||||
urlPath :: Repo -> String
|
||||
urlPath Repo { location = Url u } = uriPath u
|
||||
urlPath repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Scheme of an URL repo. -}
|
||||
urlScheme :: Repo -> String
|
||||
urlScheme Repo { location = Url u } = uriScheme u
|
||||
urlScheme repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Hostname of an URL repo. (May include a username and/or port too.) -}
|
||||
{- Hostname of an URL repo. -}
|
||||
urlHost :: Repo -> String
|
||||
urlHost Repo { location = Url u } = uriRegName a
|
||||
urlHost = urlAuthPart uriRegName
|
||||
|
||||
{- Port of an URL repo, if it has a nonstandard one. -}
|
||||
urlPort :: Repo -> Maybe Integer
|
||||
urlPort r =
|
||||
case urlAuthPart uriPort r of
|
||||
":" -> Nothing
|
||||
(':':p) -> Just (read p)
|
||||
_ -> Nothing
|
||||
|
||||
{- Hostname of an URL repo, including any username (ie, "user@host") -}
|
||||
urlHostUser :: Repo -> String
|
||||
urlHostUser r = urlAuthPart uriUserInfo r ++ urlAuthPart uriRegName r
|
||||
|
||||
{- The full authority portion an URL repo. (ie, "user@host:port") -}
|
||||
urlAuthority :: Repo -> String
|
||||
urlAuthority Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
|
||||
where
|
||||
a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
|
||||
urlHost repo = assertUrl repo $ error "internal"
|
||||
urlAuthority repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Full hostname of an URL repo. (May include a username and/or port too.) -}
|
||||
urlHostFull :: Repo -> String
|
||||
urlHostFull Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
|
||||
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
|
||||
urlAuthPart :: (URIAuth -> a) -> Repo -> a
|
||||
urlAuthPart a Repo { location = Url u } = a auth
|
||||
where
|
||||
a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
|
||||
urlHostFull repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Path of an URL repo. -}
|
||||
urlPath :: Repo -> String
|
||||
urlPath Repo { location = Url u } = uriPath u
|
||||
urlPath repo = assertUrl repo $ error "internal"
|
||||
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
|
||||
urlAuthPart _ repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Constructs a git command line operating on the specified repo. -}
|
||||
gitCommandLine :: Repo -> [CommandParam] -> [CommandParam]
|
||||
|
|
|
@ -318,7 +318,7 @@ git_annex_shell r command params
|
|||
| Git.repoIsSsh r = do
|
||||
sshoptions <- repoConfig r "ssh-options" ""
|
||||
return $ Just ("ssh", map Param (words sshoptions) ++
|
||||
[Param (Git.urlHostFull r), Param sshcmd])
|
||||
[Param (Git.urlAuthority r), Param sshcmd])
|
||||
| otherwise = return Nothing
|
||||
where
|
||||
dir = Git.workTree r
|
||||
|
|
Loading…
Reference in a new issue