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.

diff --git a/P2P/Http/Url.hs b/P2P/Http/Url.hs
index 8d52874ee36b06ab31666cf214f6c3ab5fc981f3..5d85b543534dcd60e29e0cb4c0e3af1e7c820f38 100644 (file)
--- a/P2P/Http/Url.hs
+++ b/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

diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index c85acb1929540ee5e434eecaa0d27e605c500496..53235ba66568f179f3fefa693ddd323951a344b3 100644 (file)
--- a/Types/GitConfig.hs
+++ b/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"

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index d1c117bc6d151033ff59f789f30141aac4c525ec..f97fadf324c437f94bc2191bbf16c55060b63749 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/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.