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

CHANGELOG

@@ -1,3 +1,10 @@
+git-annex (10.20250417) UNRELEASED; urgency=medium
+
+  * map: Fix buggy handling of remotes that are bare git repositories
+    accessed via ssh.
+
+ -- Joey Hess <id@joeyh.name>  Tue, 22 Apr 2025 14:33:26 -0400
+
 git-annex (10.20250416) upstream; urgency=medium
 
   * Added the mask special remote.

Command/Map.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2025 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -154,7 +154,7 @@ trustDecorate trustmap u s = case M.lookup u trustmap of
 	Just DeadTrusted -> Dot.fillColor "grey" s
 	Nothing -> Dot.fillColor "white" s
 
-{- Recursively searches out remotes starting with the specified repo. -}
+{- Recursively searches out remotes starting with the specified local repo. -}
 spider :: Git.Repo -> Annex [RepoRemotes]
 spider r = spider' [r] []
 spider' :: [Git.Repo] -> [RepoRemotes] -> Annex [RepoRemotes]
@@ -166,15 +166,18 @@ spider' (r:rs) known
 
 		-- The remotes will be relative to r', and need to be
 		-- made absolute for later use.
-		remotes <- mapM (absRepo r')
+		remotes <- mapM (absRepo r') =<<
-			=<< (liftIO $ Git.Construct.fromRemotes r')
+			if Git.repoIsUrl r
-	
+				then liftIO $ Git.Construct.fromRemoteUrlRemotes r'
+				else liftIO $ Git.Construct.fromRemotes r'
+
 		spider' (rs ++ remotes) ((r', remotes):known)
 
 {- Converts repos to a common absolute form. -}
 absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
 absRepo reference r
-	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
+	| Git.repoIsUrl reference = return $
+		Git.Construct.localToUrl reference r
 	| Git.repoIsUrl r = return r
 	| otherwise = liftIO $ do
 		r' <- Git.Construct.fromPath =<< absPath (Git.repoPath r)

Git/Construct.hs

@@ -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 :: Bool -> String -> IO Repo
-fromUrl url
+fromUrl fileurlislocal url
-	| not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
+	| not (isURI url) = fromUrl' fileurlislocal $
-	| otherwise = fromUrl' url
+		escapeURIString isUnescapedInURI url
+	| otherwise = fromUrl' fileurlislocal url
 
-fromUrl' :: String -> IO Repo
+fromUrl' :: Bool -> String -> IO Repo
-fromUrl' url
+fromUrl' fileurlislocal url
-	| "file://" `isPrefixOf` url = case parseURIPortable url of
+	| "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. -}

Remote/Bup.hs

@@ -304,7 +304,7 @@ bup2GitRemote r
 		if "/" `isPrefixOf` r
 			then Git.Construct.fromPath (toOsPath r)
 			else giveup "please specify an absolute path"
-	| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
+	| otherwise = Git.Construct.fromUrl False $ "ssh://" ++ host ++ slash dir
   where
 	bits = splitc ':' r
 	host = fromMaybe "" $ headMaybe bits