protocol version fallback on 404

and prettified errors

diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs
index 8bcd2913620331fc5348b055efac51aa7da34222..fba8dc368f8411169fdf551348a4f1abfc532dc2 100644 (file)
--- a/P2P/Http/Client.hs
+++ b/P2P/Http/Client.hs
@@ -28,6 +28,8 @@ import Annex.Concurrent
 import Servant
 import Servant.Client.Streaming
 import qualified Servant.Types.SourceT as S
+import Network.HTTP.Types.Status
+import Network.HTTP.Client
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Internal as LI
@@ -44,7 +46,7 @@ type ClientAction a
        -> B64UUID ClientSide
        -> [B64UUID Bypass]
        -> Maybe Auth
-       -> Annex a
+       -> Annex (Either ClientError a)
 
 p2pHttpClient
        :: Remote
@@ -54,22 +56,38 @@ p2pHttpClient
 #endif
        -> Annex a
 #ifdef WITH_SERVANT
-p2pHttpClient rmt _fallback clientaction =
+p2pHttpClient rmt fallback clientaction =
        case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
                Nothing -> error "internal"
                Just baseurl -> do
-                       myuuid <- getUUID
                        mgr <- httpManager <$> getUrlOptions
                        let clientenv = mkClientEnv mgr baseurl
-                       -- TODO: try other protocol versions
+                       go clientenv allProtocolVersions
+  where
+       go clientenv (v:vs) = do
+               myuuid <- getUUID
+               res <- clientaction clientenv v
+                       (B64UUID (uuid rmt))
+                       (B64UUID myuuid)
+                       []
+                       Nothing
                        -- TODO: authentication
-                       -- TODO: catch 404 etc
-                       clientaction clientenv 
-                               (ProtocolVersion 3)
-                               (B64UUID (uuid rmt))
-                               (B64UUID myuuid)
-                               []
-                               Nothing
+               case res of
+                       Right resp -> return resp
+                       Left (FailureResponse _ resp)
+                               | statusCode (responseStatusCode resp) == 404 && not (null vs) ->
+                                       go clientenv vs
+                               | otherwise -> fallback $
+                                       show (statusCode (responseStatusCode resp))
+                                               ++ " " ++
+                                       decodeBS (statusMessage (responseStatusCode resp))
+                       Left (ConnectionError ex) -> case fromException ex of
+                               Just (HttpExceptionRequest _ (ConnectionFailure err)) -> fallback $
+                                       "unable to connect to HTTP server: " ++ show err
+                               _ -> fallback (show ex)
+                       Left clienterror -> fallback $
+                                       "git-annex HTTP API server returned an unexpected response: " ++ show clienterror
+       go _ [] = error "internal"
 #else
 runP2PHttpClient rmt fallback = fallback "This remote uses an annex+http url, but this version of git-annex is not build with support for that."
 #endif
@@ -134,8 +152,8 @@ gatherByteString = unsafeInterleaveIO . go
 clientCheckPresent :: Key -> ClientAction Bool
 clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
        liftIO $ withClientM (cli su (B64Key key) cu bypass auth) clientenv $ \case
-               Left err -> throwM err
-               Right (CheckPresentResult res) -> return res
+               Left err -> return (Left err)
+               Right (CheckPresentResult res) -> return (Right res)
   where
        cli = case ver of
                3 -> flip v3 V3

diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 2bca26c06c92c44b7a93d816838ef317d5b0677a..fc5f9c30e246375a011a7533fc23166644349eb3 100644 (file)
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -63,6 +63,15 @@ defaultProtocolVersion = ProtocolVersion 0
 maxProtocolVersion :: ProtocolVersion
 maxProtocolVersion = ProtocolVersion 3
 
+-- In order from newest to oldest.
+allProtocolVersions :: [ProtocolVersion]
+allProtocolVersions =
+       [ ProtocolVersion 3
+       , ProtocolVersion 2
+       , ProtocolVersion 1
+       , ProtocolVersion 0
+       ] 
+
 newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile
        deriving (Show)
 

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index f97fadf324c437f94bc2191bbf16c55060b63749..c10e4f6345eb275dad51be90e2ff7079031097b4 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/doc/todo/git-annex_proxies.mdwn
@@ -28,12 +28,15 @@ Planned schedule of work:
 
 ## work notes
 
+* Rest of Remote.Git needs implementing.
+
+* git-annex p2phttp needs to support https. Including serving .well-known
+  for ACME.
+
 * A Locker should expire the lock on its own after 10 minutes,
   initially. Once keeplocked is called, the expiry should end with the end
   of that call.
 
-* Allow using annex+http urls in remote.name.annexUrl
-
 * Make http server support proxies and clusters.
 
 * `git-annex p2phttp` could support systemd socket activation. This would
@@ -52,6 +55,8 @@ Planned schedule of work:
 
 * added git-annex p2phttp command to serve HTTP P2P protocol
 
+* Allow using annex+http urls in remote.name.annexUrl
+
 ## items deferred until later for [[design/passthrough_proxy]]
 
 * Check annex.diskreserve when proxying for special remotes

diff --git a/git-annex.cabal b/git-annex.cabal
index 8b9bd65176fd4e6547ad0518639c0a6f6174d10c..452ab2489e9bd7f024bf3f82f7e109bcb48c733a 100644 (file)
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -320,6 +320,7 @@ Executable git-annex
       servant,
       servant-server,
       servant-client,
+      servant-client-core,
       warp (>= 3.2.8),
       warp-tls (>= 3.2.2)
     CPP-Options: -DWITH_SERVANT