diff --git a/Command/Map.hs b/Command/Map.hs index 4d0f900038..b3005e482d 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -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 diff --git a/GitRepo.hs b/GitRepo.hs index ef8ad25baa..a62d765961 100644 --- a/GitRepo.hs +++ b/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] diff --git a/Remotes.hs b/Remotes.hs index a7d6be67df..aeaa5874f3 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -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