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.

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
-	| otherwise = fromUrlStrict url
+	| not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
+	| otherwise = fromUrl' url
 
-fromUrlStrict :: String -> IO Repo
-fromUrlStrict url
-	| "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $
-		unEscapeString $ uriPath u
-	| otherwise = pure $ newFrom $ Url u
-  where
-	u = fromMaybe bad $ parseURI url
-	bad = error $ "bad url " ++ url
+fromUrl' :: String -> IO Repo
+fromUrl' url
+	| "file://" `isPrefixOf` url = case parseURI url of
+		Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
+		Nothing -> pure $ newFrom $ UnparseableUrl url
+	| otherwise = case parseURI url of
+		Just u -> pure $ newFrom $ Url u
+		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
- - gcrypt.
+ - Throws an exception if the repo does not use 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