sync: Fix parsing of gcrypt::rsync:// urls that use a relative path

Such an url is not valid; parseURI will fail on it. But git-annex doesn't
actually need to parse the url, because all it needs to do to support
syncing with it is know that it's not a local path, and use git pull and
push.

(Note that there is no good reason for the user to use such an url. An
absolute url is valid and I patched git-remote-gcrypt to support them
years ago. Still, users gonna do anything that tools allow, and
git-remote-gcrypt still supports them.)

Sponsored-by: Jack Hill on Patreon

Assistant/WebApp/Configurators/Edit.hs

@@ -235,7 +235,7 @@ editForm _new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
 		Nothing -> getRepoInfo Nothing mempty
 	g <- liftAnnex gitRepo
 	mrepo <- liftAnnex $ maybe (pure Nothing) (Just <$$> Remote.getRepo) mr
-	let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation) mrepo
+	let sshrepo = maybe False (\repo -> remoteLocationIsSshUrl (parseRemoteLocation (Git.repoLocation repo) False g)) mrepo
 	$(widgetFile "configurators/edit/nonannexremote")
 
 {- Makes any directory associated with the repository. -}

Assistant/WebApp/Gpg.hs

@@ -110,5 +110,5 @@ checkGCryptRepoEncryption location notencrypted notinstalled encrypted =
  - Only works if the gcrypt repo was created as a git-annex remote. -}
 probeGCryptRemoteUUID :: String -> Annex (Maybe UUID)
 probeGCryptRemoteUUID repolocation = do
-	r <- inRepo $ Git.Construct.fromRemoteLocation repolocation
+	r <- inRepo $ Git.Construct.fromRemoteLocation repolocation False
 	GCrypt.getGCryptUUID False r

Assistant/WebApp/RepoList.hs

@@ -186,12 +186,12 @@ repoList reposelector
 			-- Skip gcrypt repos on removable drives;
 			-- handled separately.
 			case fromProposedAccepted <$> getconfig (Accepted "gitrepo") of
-				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr g) ->
+				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr False g) ->
 					val True EnableSshGCryptR
 				_ -> Nothing
 		Just "git" -> 
 			case fromProposedAccepted <$> getconfig (Accepted "location") of
-				Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc g) ->
+				Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc False g) ->
 					val True EnableSshGitRemoteR
 				_ -> Nothing
 		_ -> Nothing

CHANGELOG

@@ -1,3 +1,9 @@
+git-annex (10.20230322) UNRELEASED; urgency=medium
+
+  * sync: Fix parsing of gcrypt::rsync:// urls that use a relative path.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 23 Mar 2023 15:04:41 -0400
+
 git-annex (10.20230321) upstream; urgency=medium
 
   * Using git-annex view in an adjusted branch, or git-annex adjust in a

Command/Sync.hs

@@ -220,7 +220,7 @@ seek' o = do
 	let withbranch a = a =<< getCurrentBranch
 
 	remotes <- syncRemotes (syncWith o)
-	-- Remotes that are git repositories, not special remotes.
+	-- Remotes that are git repositories, not (necesarily) special remotes.
 	let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes
 	-- Remotes that contain annex object content.
 	contentremotes <- filter (\r -> Remote.uuid r /= NoUUID)

Git/Construct.hs

@@ -140,7 +140,7 @@ fromRemotes repo = catMaybes <$> mapM construct remotepairs
 	filterkeys f = filterconfig (\(k,_) -> f k)
 	remotepairs = filterkeys isRemoteUrlKey
 	construct (k,v) = remoteNamedFromKey k $
-		fromRemoteLocation (fromConfigValue v) repo
+		fromRemoteLocation (fromConfigValue v) False repo
 
 {- Sets the name of a remote when constructing the Repo to represent it. -}
 remoteNamed :: String -> IO Repo -> IO Repo
@@ -156,9 +156,15 @@ remoteNamedFromKey k r = case remoteKeyToRemoteName k of
 	Just n -> Just <$> remoteNamed n r
 
 {- Constructs a new Repo for one of a Repo's remotes using a given
- - location (ie, an url). -}
+ - location (ie, an url). 
-fromRemoteLocation :: String -> Repo -> IO Repo
+ -
-fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
+ - knownurl can be true if the location is known to be an url. This allows
+ - urls that don't parse as urls to be used, returning UnparseableUrl.
+ - If knownurl is false, the location may still be an url, if it parses as
+ - one.
+ -}
+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

Git/GCrypt.hs

@@ -55,7 +55,15 @@ encryptedRemote baserepo = go
 			    -- allows them); need to de-escape any such
 			    -- to get back the path to the repository.
 			    l' = Network.URI.unEscapeString l
-			in fromRemoteLocation l' baserepo
+			    -- gcrypt supports relative urls for rsync 
+			    -- like "rsync://host:relative/path"
+			    -- but that does not parse as a valid url
+			    -- (while the absolute urls it supports are
+			    -- valid). 
+			    -- In order to support it, force treating it as
+			    -- an url.
+			    knownurl = "rsync://" `isPrefixOf` l'
+			in fromRemoteLocation l' knownurl baserepo
 		| otherwise = notencrypted
 
 	notencrypted = giveup "not a gcrypt encrypted repository"

Git/Remote.hs

@@ -63,7 +63,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of
 	legal c = isAlphaNum c
 	
 data RemoteLocation = RemoteUrl String | RemotePath FilePath
-	deriving (Eq)
+	deriving (Eq, Show)
 
 remoteLocationIsUrl :: RemoteLocation -> Bool
 remoteLocationIsUrl (RemoteUrl _) = True
@@ -75,16 +75,18 @@ remoteLocationIsSshUrl _ = False
 
 {- Determines if a given remote location is an url, or a local
  - path. Takes the repository's insteadOf configuration into account. -}
-parseRemoteLocation :: String -> Repo -> RemoteLocation
+parseRemoteLocation :: String -> Bool -> Repo -> RemoteLocation
-parseRemoteLocation s repo = ret $ calcloc s
+parseRemoteLocation s knownurl repo = go
   where
-	ret v
+ 	s' = calcloc s
+	go
 #ifdef mingw32_HOST_OS
-		| dosstyle v = RemotePath (dospath v)
+		| dosstyle s' = RemotePath (dospath s')
 #endif
-		| scpstyle v = RemoteUrl (scptourl v)
+		| scpstyle s' = RemoteUrl (scptourl s')
-		| urlstyle v = RemoteUrl v
+		| urlstyle s' = RemoteUrl s'
-		| otherwise = RemotePath v
+		| knownurl && s' == s = RemoteUrl s'
+		| otherwise = RemotePath s'
 	-- insteadof config can rewrite remote location
 	calcloc l
 		| null insteadofs = l

Remote/GCrypt.hs

@@ -266,7 +266,7 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c
 				let u = genUUIDInNameSpace gCryptNameSpace gcryptid
 				if Just u == mu || isNothing mu
 					then do
-						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo)
+						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo False)
 						gitConfigSpecialRemote u c' [("gcrypt", fromAccessMethod method)]
 						return (c', u)
 					else giveup $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")"

Remote/Git.hs

@@ -102,7 +102,7 @@ list autoinit = do
 			Nothing -> return r
 			Just url -> inRepo $ \g ->
 				Git.Construct.remoteNamed n $
-					Git.Construct.fromRemoteLocation (Git.fromConfigValue url) g
+					Git.Construct.fromRemoteLocation (Git.fromConfigValue url) False g
 
 {- Git remotes are normally set up using standard git commands, not
  - git-annex initremote and enableremote.
@@ -118,7 +118,7 @@ gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remote
 gitSetup Init mu _ c _ = do
 	let location = maybe (giveup "Specify location=url") fromProposedAccepted $
 		M.lookup locationField c
-	r <- inRepo $ Git.Construct.fromRemoteLocation location
+	r <- inRepo $ Git.Construct.fromRemoteLocation location False
 	r' <- tryGitConfigRead False r False
 	let u = getUncachedUUID r'
 	if u == NoUUID

Remote/GitLFS.hs

@@ -203,7 +203,7 @@ configKnownUrl r
 			<$> M.lookup Annex.SpecialRemote.Config.typeField c
 		u <- fromProposedAccepted
 			<$> M.lookup urlField c
-		let u' = Git.Remote.parseRemoteLocation u g
+		let u' = Git.Remote.parseRemoteLocation u False g
 		return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u' 
 			&& t == typename remote
 	go u mcu = do

doc/bugs/gcrypt_remotes_using_relative_paths.mdwn

@@ -36,3 +36,4 @@ Flow 2 (absolute path, working)
 ### Have you had any luck using git-annex before? (Sometimes we get tired of reading bug reports all day and a lil' positive end note does wonders)
 I am VERY happy with git annex and am using it successfully with a gcrypt remote using an absolute path :)
 
+> [[fixed|done]] --[[Joey]]