use git credential when p2phttp needs auth

diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs
index fba8dc368f8411169fdf551348a4f1abfc532dc2..4b5ea987ed65abfe90dfbda188edc715c128b377 100644 (file)
--- a/P2P/Http/Client.hs
+++ b/P2P/Http/Client.hs
@@ -24,8 +24,11 @@ import P2P.Http.Url
 import Annex.Common
 import P2P.Protocol hiding (Offset, Bypass, auth)
 import Annex.Concurrent
+import Messages
+import Utility.Url (BasicAuth(..))
+import qualified Git.Credential as Git
 
-import Servant
+import Servant hiding (BasicAuthData(..))
 import Servant.Client.Streaming
 import qualified Servant.Types.SourceT as S
 import Network.HTTP.Types.Status
@@ -62,32 +65,55 @@ p2pHttpClient rmt fallback clientaction =
                Just baseurl -> do
                        mgr <- httpManager <$> getUrlOptions
                        let clientenv = mkClientEnv mgr baseurl
-                       go clientenv allProtocolVersions
+                       go clientenv Nothing Nothing allProtocolVersions
   where
-       go clientenv (v:vs) = do
+       go clientenv mcred mauth (v:vs) = do
                myuuid <- getUUID
                res <- clientaction clientenv v
                        (B64UUID (uuid rmt))
                        (B64UUID myuuid)
                        []
-                       Nothing
-                       -- TODO: authentication
+                       mauth
                case res of
-                       Right resp -> return resp
+                       Right resp -> do
+                               maybe noop (\cred -> inRepo $ Git.approveUrlCredential cred) mcred
+                               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))
+                                       go clientenv mcred mauth vs
+                               | statusCode (responseStatusCode resp) == 401 ->
+                                       case mcred of
+                                               Nothing -> authrequired clientenv (v:vs)
+                                               Just cred -> do
+                                                       inRepo $ Git.rejectUrlCredential cred
+                                                       fallback (showstatuscode resp)
+                               | otherwise -> fallback (showstatuscode 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"
+       go _ _ _ [] = error "internal"
+
+       authrequired clientenv vs = 
+               case p2pHttpUrlString <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
+                       Nothing -> error "internal"
+                       Just url -> do
+                               cred <- prompt (inRepo $ Git.getUrlCredential url)
+                               let mauth = do
+                                       ba <- Git.credentialBasicAuth cred
+                                       return $ Auth
+                                               (encodeBS (basicAuthUser ba))
+                                               (encodeBS (basicAuthPassword ba))
+                               let mcred = if isJust mauth then Just cred else Nothing
+                               go clientenv mcred mauth vs
+
+       showstatuscode resp = 
+               show (statusCode (responseStatusCode resp))
+                       ++ " " ++
+               decodeBS (statusMessage (responseStatusCode resp))
+
 #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

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index ad221aa9a15eb7964025838c981754cc6b161449..4e1c6d0420cb2125197841101e2f745799a6828c 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/doc/todo/git-annex_proxies.mdwn
@@ -28,6 +28,8 @@ Planned schedule of work:
 
 ## work notes
 
+* cache git credential auth
+
 * Rest of Remote.Git needs implementing.
 
 * git-annex p2phttp serving .well-known for ACME.