add remoteAnnexP2PHttpUrl to RemoveGitConfig

This is always parsed, when building without servant, a Baseurl is not
generated, and users of it will need to fail.

P2P/Http/Url.hs

@@ -5,9 +5,16 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module P2P.Http.Url where
 
 import Data.List
+import Network.URI
+#ifdef WITH_SERVANT
+import Servant.Client (BaseUrl(..), Scheme(..))
+import Text.Read
+#endif
 
 defaultP2PHttpProtocolPort :: Int
 defaultP2PHttpProtocolPort = 9417 -- Git protocol is 9418
@@ -16,3 +23,41 @@ isP2PHttpProtocolUrl :: String -> Bool
 isP2PHttpProtocolUrl s = 
 	"annex+http://" `isPrefixOf` s ||
 	"annex+https://" `isPrefixOf` s
+
+data P2PHttpUrl =
+#ifdef WITH_SERVANT
+	P2PHttpUrl String BaseUrl
+#else
+	P2PHttpUrl String
+#endif
+
+parseP2PHttpUrl :: String -> Maybe P2PHttpUrl
+parseP2PHttpUrl us
+	| isP2PHttpProtocolUrl us = case parseURI (drop prefixlen us) of
+		Nothing -> Nothing
+#ifdef WITH_SERVANT
+		Just u -> 
+			case uriScheme u of
+				"http:" -> mkbaseurl Http u
+				"https:" -> mkbaseurl Https u
+				_ -> Nothing
+#else
+		Just _ -> 
+			Just (P2PHttpUrl us)
+#endif
+	| otherwise = Nothing
+  where
+	prefixlen = length "annex+"
+#ifdef WITH_SERVANT
+	mkbaseurl s u = do
+		auth <- uriAuthority u
+		port <- if null (uriPort auth)
+			then Just defaultP2PHttpProtocolPort
+			else readMaybe (dropWhile (== ':') (uriPort auth))
+		return $ P2PHttpUrl us $ BaseUrl
+			{ baseUrlScheme = s
+			, baseUrlHost = uriRegName auth
+			, baseUrlPath = uriPath u
+			, baseUrlPort = port
+			}
+#endif

Types/GitConfig.hs

@@ -55,6 +55,7 @@ import Utility.StatelessOpenPGP (SOPCmd(..), SOPProfile(..))
 import Utility.ThreadScheduler (Seconds(..))
 import Utility.Url (Scheme, mkScheme)
 import Network.Socket (PortNumber)
+import P2P.Http.Url
 
 import Control.Concurrent.STM
 import qualified Data.Set as S
@@ -395,6 +396,7 @@ data RemoteGitConfig = RemoteGitConfig
 	, remoteAnnexClusterNode :: Maybe [RemoteName]
 	, remoteAnnexClusterGateway :: [ClusterUUID]
 	, remoteUrl :: Maybe String
+	, remoteAnnexP2PHttpUrl :: Maybe P2PHttpUrl
 
 	{- These settings are specific to particular types of remotes
 	 - including special remotes. -}
@@ -493,6 +495,11 @@ extractRemoteGitConfig r remotename = do
 					| B.null b -> Nothing
 					| otherwise -> Just (decodeBS b)
 				_ -> Nothing
+		, remoteAnnexP2PHttpUrl =
+			case Git.Config.getMaybe (remoteConfig remotename (remoteGitConfigKey AnnexUrlField)) r of
+				Just (ConfigValue b) ->
+					parseP2PHttpUrl (decodeBS b)
+				_ -> Nothing
 		, remoteAnnexShell = getmaybe ShellField
 		, remoteAnnexSshOptions = getoptions SshOptionsField
 		, remoteAnnexRsyncOptions = getoptions RsyncOptionsField
@@ -569,6 +576,7 @@ data RemoteGitConfigField
 	| ClusterNodeField
 	| ClusterGatewayField
 	| UrlField
+	| AnnexUrlField
 	| ShellField
 	| SshOptionsField
 	| RsyncOptionsField
@@ -637,6 +645,7 @@ remoteGitConfigField = \case
 	ClusterNodeField -> uninherited "cluster-node"
 	ClusterGatewayField -> uninherited "cluster-gateway"
 	UrlField -> uninherited "url"
+	AnnexUrlField -> uninherited "annexurl"
 	ShellField -> inherited "shell"
 	SshOptionsField -> inherited "ssh-options"
 	RsyncOptionsField -> inherited "rsync-options"

doc/todo/git-annex_proxies.mdwn

@@ -32,7 +32,7 @@ Planned schedule of work:
   initially. Once keeplocked is called, the expiry should end with the end
   of that call.
 
-* Make Remote.Git use http client when remote.name.annex-url is configured.
+* Allow using annex+http urls in remote.name.annexUrl
 
 * Make http server support proxies and clusters.