map: Fix buggy handling of remotes that are bare git repositories accessed via ssh

It was treating remote paths of a remote repo as if they were local paths,
and so trying to expand git directories and so forth on them. That led to
bad results, including a path like "foo.git" getting turned into
"foo.git.git"

Sponsored-by: Dartmouth College's OpenNeuro project
This commit is contained in:
Joey Hess 2025-04-22 15:08:49 -04:00
parent 820b591c1f
commit 2ee6c25c72
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 49 additions and 20 deletions

View file

@ -1,6 +1,6 @@
{- Construction of Git Repo objects
-
- Copyright 2010-2023 Joey Hess <id@joeyh.name>
- Copyright 2010-2025 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -18,6 +18,7 @@ module Git.Construct (
remoteNamed,
remoteNamedFromKey,
fromRemotes,
fromRemoteUrlRemotes,
fromRemoteLocation,
repoAbsPath,
checkForRepo,
@ -97,14 +98,15 @@ fromAbsPath dir
- or is invalid, because git can also function despite remotes having
- such urls, only failing if such a remote is used.
-}
fromUrl :: String -> IO Repo
fromUrl url
| not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
| otherwise = fromUrl' url
fromUrl :: Bool -> String -> IO Repo
fromUrl fileurlislocal url
| not (isURI url) = fromUrl' fileurlislocal $
escapeURIString isUnescapedInURI url
| otherwise = fromUrl' fileurlislocal url
fromUrl' :: String -> IO Repo
fromUrl' url
| "file://" `isPrefixOf` url = case parseURIPortable url of
fromUrl' :: Bool -> String -> IO Repo
fromUrl' fileurlislocal url
| "file://" `isPrefixOf` url && fileurlislocal = case parseURIPortable url of
Just u -> fromAbsPath $ toOsPath $ unEscapeString $ uriPath u
Nothing -> pure $ newFrom $ UnparseableUrl url
| otherwise = case parseURIPortable url of
@ -123,24 +125,41 @@ localToUrl reference r
| repoIsUrl r = r
| otherwise = case (Url.authority reference, Url.scheme reference) of
(Just auth, Just s) ->
let absurl = concat
let referencepath = fromMaybe "" $ Url.path reference
absurl = concat
[ s
, "//"
, auth
, fromOsPath (repoPath r)
, fromOsPath $
toOsPath referencepath </> repoPath r
]
in r { location = Url $ fromJust $ parseURIPortable absurl }
_ -> r
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo]
fromRemotes repo = catMaybes <$> mapM construct remotepairs
fromRemotes = fromRemotes' fromRemoteLocation
fromRemotes' :: (String -> Bool -> Repo -> IO Repo) -> Repo -> IO [Repo]
fromRemotes' fromremotelocation repo = catMaybes <$> mapM construct remotepairs
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isRemoteUrlKey
construct (k,v) = remoteNamedFromKey k $
fromRemoteLocation (fromConfigValue v) False repo
fromremotelocation (fromConfigValue v) False repo
{- Calculates a list of a remote repo's configured remotes, by parsing its
- config. Unlike fromRemotes, this does not do any local path checking.
- The remote repo must have an url path. -}
fromRemoteUrlRemotes :: Repo -> IO [Repo]
fromRemoteUrlRemotes = fromRemotes' go
where
go s knownurl repo =
case parseRemoteLocation s knownurl repo of
RemotePath p -> pure $ localToUrl repo $
newFrom $ LocalUnknown $ toOsPath p
RemoteUrl u -> fromUrl False u
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
@ -167,7 +186,7 @@ fromRemoteLocation :: String -> Bool -> Repo -> IO Repo
fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo
where
gen (RemotePath p) = fromRemotePath p repo
gen (RemoteUrl u) = fromUrl u
gen (RemoteUrl u) = fromUrl True u
{- Constructs a Repo from the path specified in the git remotes of
- another Repo. -}