Windows: Support urls like "file:///c:/path"

That is a legal url, but parseUrl parses it to "/c:/path"
which is not a valid path on Windows. So as a workaround, use
parseURIPortable everywhere, which removes the leading slash when
run on windows.

Note that if an url is parsed like this and then serialized back
to a string, it will be different from the input. Which could
potentially be a problem, but is probably not in practice.

An alternative way to do it would be to have an uriPathPortable
that fixes up the path after parsing. But it would be harder to
make sure that is used everywhere, since uriPath is also used
when constructing an URI.

It's also worth noting that System.FilePath.normalize "/c:/path"
yields "c:/path". The reason I didn't use it is that it also
may change "/" to "\" in the path and I wanted to keep the url
changes minimal. Also noticed that convertToWindowsNativeNamespace
handles "/c:/path" the same as "c:/path".

Sponsored-By: the NIH-funded NICEMAN (ReproNim TR&D3) project

Assistant/Restart.hs

@@ -100,7 +100,7 @@ assistantListening url = catchBoolIO $ do
 	uo <- defUrlOptions
 	(== Right True) <$> exists url' uo
   where
-	url' = case parseURI url of
+	url' = case parseURIPortable url of
 		Nothing -> url
 		Just uri -> show $ uri
 			{ uriScheme = "http:"

Assistant/WebApp/Configurators/WebDAV.hs

@@ -22,6 +22,7 @@ import Assistant.Gpg
 import Types.GitConfig
 import Annex.SpecialRemote.Config
 import Types.ProposedAccepted
+import Utility.Url
 
 import qualified Data.Map as M
 import qualified Data.Text as T
@@ -96,4 +97,4 @@ previouslyUsedWebDAVCreds hostname =
 		Just h -> h == hostname
 
 urlHost :: String -> Maybe String
-urlHost url = uriRegName <$> (uriAuthority =<< parseURI url)
+urlHost url = uriRegName <$> (uriAuthority =<< parseURIPortable url)

CHANGELOG

@@ -7,6 +7,7 @@ git-annex (10.20230322) UNRELEASED; urgency=medium
     checking out an updated adjusted branch.
   * view: Support annex.maxextensionlength when generating filenames for
     the view branch.
+  * Windows: Support urls like "file:///c:/path"
 
  -- Joey Hess <id@joeyh.name>  Thu, 23 Mar 2023 15:04:41 -0400
 

Command/AddUrl.hs

@@ -31,6 +31,7 @@ import Logs.Location
 import Utility.Metered
 import Utility.HtmlDetect
 import Utility.Path.Max
+import Utility.Url (parseURIPortable)
 import qualified Utility.RawFilePath as R
 import qualified Annex.Transfer as Transfer
 
@@ -220,7 +221,7 @@ downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \ca
 	af = AssociatedFile (Just file)
 
 startWeb :: AddUnlockedMatcher -> AddUrlOptions -> SeekInput -> URLString -> CommandStart
-startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURI urlstring
+startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURIPortable urlstring
   where
 	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
 		Url.parseURIRelaxed $ urlstring

Command/FromKey.hs

@@ -18,6 +18,7 @@ import Annex.Link
 import Annex.FileMatcher
 import Annex.Ingest
 import Git.FilePath
+import Utility.Url
 
 import Network.URI
 
@@ -89,7 +90,7 @@ keyOpt :: String -> Key
 keyOpt = either giveup id . keyOpt'
 
 keyOpt' :: String -> Either String Key
-keyOpt' s = case parseURI s of
+keyOpt' s = case parseURIPortable s of
 	Just u | not (isKeyPrefix (uriScheme u)) ->
 		Right $ Backend.URL.fromUrl s Nothing
 	_ -> case deserializeKey s of

Git/Construct.hs

@@ -39,6 +39,7 @@ import Git.Remote
 import Git.FilePath
 import qualified Git.Url as Url
 import Utility.UserInfo
+import Utility.Url (parseURIPortable)
 
 import qualified Data.ByteString as B
 import qualified System.FilePath.ByteString as P
@@ -104,10 +105,10 @@ fromUrl url
 
 fromUrl' :: String -> IO Repo
 fromUrl' url
-	| "file://" `isPrefixOf` url = case parseURI url of
+	| "file://" `isPrefixOf` url = case parseURIPortable url of
 		Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
 		Nothing -> pure $ newFrom $ UnparseableUrl url
-	| otherwise = case parseURI url of
+	| otherwise = case parseURIPortable url of
 		Just u -> pure $ newFrom $ Url u
 		Nothing -> pure $ newFrom $ UnparseableUrl url
 
@@ -129,7 +130,7 @@ localToUrl reference r
 				, auth
 				, fromRawFilePath (repoPath r)
 				]
-			in r { location = Url $ fromJust $ parseURI absurl }
+			in r { location = Url $ fromJust $ parseURIPortable absurl }
 		_ -> r
 
 {- Calculates a list of a repo's configured remotes, by parsing its config. -}

Git/Credential.hs

@@ -117,7 +117,7 @@ data CredentialBaseURL = CredentialBaseURL URI
 
 mkCredentialBaseURL :: Repo -> URLString -> Maybe CredentialBaseURL
 mkCredentialBaseURL r s = do
-	u <- parseURI s
+	u <- parseURIPortable s
 	let usehttppath = fromMaybe False $ Config.isTrueFalse' $
 		Config.get (ConfigKey "credential.useHttpPath") (ConfigValue "") r
 	if usehttppath

Remote/BitTorrent.hs

@@ -23,6 +23,7 @@ import Types.CleanupActions
 import Messages.Progress
 import Utility.Metered
 import Utility.Tmp
+import Utility.Url (parseURIPortable)
 import Backend.URL
 import Annex.Perms
 import Annex.Tmp
@@ -141,10 +142,10 @@ isSupportedUrl :: URLString -> Bool
 isSupportedUrl u = isTorrentMagnetUrl u || isTorrentUrl u
 
 isTorrentUrl :: URLString -> Bool
-isTorrentUrl = maybe False (\u -> ".torrent" `isSuffixOf` uriPath u) . parseURI
+isTorrentUrl = maybe False (\u -> ".torrent" `isSuffixOf` uriPath u) . parseURIPortable
 
 isTorrentMagnetUrl :: URLString -> Bool
-isTorrentMagnetUrl u = "magnet:" `isPrefixOf` u && checkbt (parseURI u)
+isTorrentMagnetUrl u = "magnet:" `isPrefixOf` u && checkbt (parseURIPortable u)
   where
 	checkbt (Just uri) | "xt=urn:btih:" `isInfixOf` uriQuery uri = True
 	checkbt _ = False

Remote/External/Types.hs

@@ -53,7 +53,7 @@ import Types.Export
 import Types.Availability (Availability(..))
 import Types.Key
 import Git.Types
-import Utility.Url (URLString)
+import Utility.Url (URLString, parseURIPortable)
 import qualified Utility.SimpleProtocol as Proto
 
 import Control.Concurrent.STM
@@ -462,7 +462,7 @@ instance Proto.Serializable [(URLString, Size, FilePath)] where
 
 instance Proto.Serializable URI where
 	serialize = show
-	deserialize = parseURI
+	deserialize = parseURIPortable
 
 instance Proto.Serializable ExportLocation where
 	serialize = fromRawFilePath . fromExportLocation

RemoteDaemon/Types.hs

@@ -15,6 +15,7 @@ import qualified Git.Types as Git
 import qualified Utility.SimpleProtocol as Proto
 import Types.GitConfig
 import Annex.ChangedRefs (ChangedRefs)
+import Utility.Url
 
 import Network.URI
 import Control.Concurrent
@@ -100,7 +101,7 @@ instance Proto.Receivable Consumed where
 
 instance Proto.Serializable RemoteURI where
 	serialize (RemoteURI u) = show u
-	deserialize = RemoteURI <$$> parseURI
+	deserialize = RemoteURI <$$> parseURIPortable
 
 instance Proto.Serializable Bool where
 	serialize False = "0"

Utility/Url.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 
 module Utility.Url (
 	newManager,
@@ -32,6 +33,7 @@ module Utility.Url (
 	downloadConduit,
 	sinkResponseFile,
 	downloadPartial,
+	parseURIPortable,
 	parseURIRelaxed,
 	matchStatusCodeException,
 	matchHttpExceptionContent,
@@ -71,6 +73,9 @@ import Network.BSD (getProtocolNumber)
 import Data.Either
 import Data.Conduit
 import Text.Read
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Windows as PW
+#endif
 
 type URLString = String
 
@@ -608,10 +613,29 @@ downloadPartial url uo n = case parseURIRelaxed url of
 					then Just <$> brReadSome (responseBody resp) n
 					else return Nothing
 
+{- On unix this is the same as parseURI. But on Windows,
+ - it can parse urls such as file:///C:/path/to/file
+ - parseURI normally parses that as a path /C:/path/to/file
+ - and this simply removes the excess leading slash when there is a
+ - drive letter after it. -}
+parseURIPortable :: URLString -> Maybe URI
+#ifndef mingw32_HOST_OS
+parseURIPortable = parseURI
+#else
+parseURIPortable s
+	| "file:" `isPrefixOf` s = do
+		u <- parseURI s
+		return $ case PW.splitDirectories (uriPath u) of
+			(p:d:_) | all PW.isPathSeparator p && PW.isDrive d ->
+				u { uriPath = dropWhile PW.isPathSeparator (uriPath u) }
+			_ -> u
+	| otherwise = parseURI s
+#endif
+
 {- Allows for spaces and other stuff in urls, properly escaping them. -}
 parseURIRelaxed :: URLString -> Maybe URI
 parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $
-	parseURI $ escapeURIString isAllowedInURI s
+	parseURIPortable $ escapeURIString isAllowedInURI s
 
 {- Generate a http-conduit Request for an URI. This is able
  - to deal with some urls that parseRequest would usually reject.