diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs index 8bcd291362..fba8dc368f 100644 --- 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 2bca26c06c..fc5f9c30e2 100644 --- 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 f97fadf324..c10e4f6345 100644 --- 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 8b9bd65176..452ab2489e 100644 --- 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