avoid crashing when there are remotes using unparseable urls

Including the non-standard URI form that git-remote-gcrypt uses for rsync.

Eg, "ook://foo:bar" cannot be parsed because "bar" is not a valid port
number. But git could have a remote with that, it would try to run
git-remote-ook to handle it. So, git-annex has to allow for such things,
rather than crashing.

This commit was sponsored by Luke Shumaker on Patreon.

CHANGELOG

@@ -28,6 +28,8 @@ git-annex (8.20201130) UNRELEASED; urgency=medium
   * Bug fix: Fix tilde expansion in ssh urls when the tilde is the last
     character in the url.
     Thanks, Grond for the patch.
+  * Avoid crashing when there are remotes using unparseable urls.
+    Including the non-standard URI form that git-remote-gcrypt uses for rsync.
 
  -- Joey Hess <id@joeyh.name>  Mon, 04 Jan 2021 12:52:41 -0400
 

Git.hs

@@ -3,7 +3,7 @@
  - This is written to be completely independant of git-annex and should be
  - suitable for other uses.
  -
- - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -55,6 +55,7 @@ import Utility.FileMode
 repoDescribe :: Repo -> String
 repoDescribe Repo { remoteName = Just name } = name
 repoDescribe Repo { location = Url url } = show url
+repoDescribe Repo { location = UnparseableUrl url } = url
 repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
 repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
 repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir
@@ -63,13 +64,14 @@ repoDescribe Repo { location = Unknown } = "UNKNOWN"
 {- Location of the repo, either as a path or url. -}
 repoLocation :: Repo -> String
 repoLocation Repo { location = Url url } = show url
+repoLocation Repo { location = UnparseableUrl url } = url
 repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
 repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
 repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir
 repoLocation Repo { location = Unknown } = error "unknown repoLocation"
 
 {- Path to a repository. For non-bare, this is the worktree, for bare, 
- - it's the gitdir, and for URL repositories, is the path on the remote
+ - it's the gitdit, and for URL repositories, is the path on the remote
  - host. -}
 repoPath :: Repo -> RawFilePath
 repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u
@@ -77,6 +79,7 @@ repoPath Repo { location = Local { worktree = Just d } } = d
 repoPath Repo { location = Local { gitdir = d } } = d
 repoPath Repo { location = LocalUnknown dir } = dir
 repoPath Repo { location = Unknown } = error "unknown repoPath"
+repoPath Repo { location = UnparseableUrl _u } = error "unknwon repoPath"
 
 repoWorkTree :: Repo -> Maybe RawFilePath
 repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
@@ -91,6 +94,7 @@ localGitDir _ = error "unknown localGitDir"
  - or bare and non-bare, these functions help with that. -}
 repoIsUrl :: Repo -> Bool
 repoIsUrl Repo { location = Url _ } = True
+repoIsUrl Repo { location = UnparseableUrl _ } = True
 repoIsUrl _ = False
 
 repoIsSsh :: Repo -> Bool

Git/Construct.hs

@@ -1,6 +1,6 @@
 {- Construction of Git Repo objects
  -
- - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -87,24 +87,29 @@ fromAbsPath dir
 				else ret dir
 			)
 
-{- Remote Repo constructor. Throws exception on invalid url.
+{- Construct a Repo for a remote's url.
  -
  - Git is somewhat forgiving about urls to repositories, allowing
- - eg spaces that are not normally allowed unescaped in urls.
+ - eg spaces that are not normally allowed unescaped in urls. Such
+ - characters get escaped.
+ -
+ - This will always succeed, even if the url cannot be parsed
+ - 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) = fromUrlStrict $ escapeURIString isUnescapedInURI url
+	| not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
-	| otherwise = fromUrlStrict url
+	| otherwise = fromUrl' url
 
-fromUrlStrict :: String -> IO Repo
+fromUrl' :: String -> IO Repo
-fromUrlStrict url
+fromUrl' url
-	| "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $
+	| "file://" `isPrefixOf` url = case parseURI url of
-		unEscapeString $ uriPath u
+		Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
-	| otherwise = pure $ newFrom $ Url u
+		Nothing -> pure $ newFrom $ UnparseableUrl url
-  where
+	| otherwise = case parseURI url of
-	u = fromMaybe bad $ parseURI url
+		Just u -> pure $ newFrom $ Url u
-	bad = error $ "bad url " ++ url
+		Nothing -> pure $ newFrom $ UnparseableUrl url
 
 {- Creates a repo that has an unknown location. -}
 fromUnknown :: Repo

Git/GCrypt.hs

@@ -28,6 +28,7 @@ urlPrefix = urlScheme ++ ":"
 
 isEncrypted :: Repo -> Bool
 isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url
+isEncrypted Repo { location = UnparseableUrl url } = urlPrefix `isPrefixOf` url
 isEncrypted _ = False
 
 {- The first Repo is the git repository that has the second Repo
@@ -36,22 +37,24 @@ isEncrypted _ = False
  - When the remote Repo uses gcrypt, returns the actual underlying
  - git repository that gcrypt is using to store its data. 
  -
- - Throws an exception if an url is invalid or the repo does not use
+ - Throws an exception if the repo does not use gcrypt.
- - gcrypt.
  -}
 encryptedRemote :: Repo -> Repo -> IO Repo
 encryptedRemote baserepo = go
   where
-	go Repo { location = Url url }
+	go Repo { location = Url url } = go' (show url)
+	go Repo { location = UnparseableUrl url } = go' url
+	go _ = notencrypted
+
+	go' u
 		| urlPrefix `isPrefixOf` u =
 			fromRemoteLocation (drop plen u) baserepo
 		| otherwise = notencrypted
-	  where
+
-		u = show url
-		plen = length urlPrefix
-	go _ = notencrypted
 	notencrypted = giveup "not a gcrypt encrypted repository"
 
+	plen = length urlPrefix
+
 data ProbeResult = Decryptable | NotDecryptable | NotEncrypted
 
 {- Checks if the git repo at a location uses gcrypt.

Git/Types.hs

@@ -34,6 +34,7 @@ data RepoLocation
 	= Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }
 	| LocalUnknown RawFilePath
 	| Url URI
+	| UnparseableUrl String
 	| Unknown
 	deriving (Show, Eq, Ord)
 

Git/Url.hs

@@ -1,6 +1,6 @@
 {- git repository urls
  -
- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -23,6 +23,7 @@ import Git
 {- Scheme of an URL repo. -}
 scheme :: Repo -> String
 scheme Repo { location = Url u } = uriScheme u
+scheme Repo { location = UnparseableUrl u } = unparseableUrl u
 scheme repo = notUrl repo
 
 {- Work around a bug in the real uriRegName
@@ -65,13 +66,18 @@ authority = authpart assemble
 {- Applies a function to extract part of the uriAuthority of an URL repo. -}
 authpart :: (URIAuth -> a) -> Repo -> Maybe a
 authpart a Repo { location = Url u } = a <$> uriAuthority u
+authpart _ Repo { location = UnparseableUrl u } = unparseableUrl u
 authpart _ repo = notUrl repo
 
 {- Path part of an URL repo. -}
 path :: Repo -> FilePath
 path Repo { location = Url u } = uriPath u
+path Repo { location = UnparseableUrl u } = unparseableUrl u
 path repo = notUrl repo
 
 notUrl :: Repo -> a
 notUrl repo = error $
 	"acting on local git repo " ++ repoDescribe repo ++ " not supported"
+
+unparseableUrl :: String -> a
+unparseableUrl u = error $ "unable to parse repo url " ++ u

Remote/GCrypt.hs

@@ -67,7 +67,7 @@ remote :: RemoteType
 remote = specialRemoteType $ RemoteType
 	{ typename = "gcrypt"
 	-- Remote.Git takes care of enumerating gcrypt remotes too,
-	-- and will call our gen on them.
+	-- and will call our chainGen on them.
 	, enumerate = const (return [])
 	, generate = gen
 	, configParser = mkRemoteConfigParser $

doc/bugs/git_annex_doesn__39__t_cope_with_a_gcrypt__58____58__rsync__58____47____47__.mdwn

@@ -13,3 +13,6 @@ After adding a `gcrypt::rsync://` remote, `git-annex-sync` and `git-annex-info`
 
 ### What version of git-annex are you using? On what operating system?
 git-annex version: 8.20201127
+
+> [[done]], it will no longer crash, and git-annex sync will work
+> --[[Joey]]