protocol version fallback on 404

and prettified errors

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

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)
 

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

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