cache credentials for p2phttp in memory

Git/Credential.hs

@@ -42,7 +42,7 @@ getBasicAuthFromCredential r ccv u = do
 			Just c -> go (const noop) c
 			Nothing -> do
 				let storeincache = \c -> atomically $ do
-					(CredentialCache cc') <- takeTMVar ccv
+					CredentialCache cc' <- takeTMVar ccv
 					putTMVar ccv (CredentialCache (M.insert bu c cc'))
 				go storeincache =<< getUrlCredential u r
 		Nothing -> go (const noop) =<< getUrlCredential u r
@@ -113,7 +113,9 @@ data CredentialCache = CredentialCache (M.Map CredentialBaseURL Credential)
 -- when credential.useHttpPath is false, one Credential is cached
 -- for each git repo accessed, and there are a reasonably small number of
 -- those, so the cache will not grow too large.
-data CredentialBaseURL = CredentialBaseURL URI
+data CredentialBaseURL
+	= CredentialBaseURI URI
+	| CredentialBaseURL String
 	deriving (Show, Eq, Ord)
 
 mkCredentialBaseURL :: Repo -> URLString -> Maybe CredentialBaseURL
@@ -123,4 +125,4 @@ mkCredentialBaseURL r s = do
 		Config.get (ConfigKey "credential.useHttpPath") (ConfigValue "") r
 	if usehttppath
 		then Nothing
-		else Just $ CredentialBaseURL $ u { uriPath = "" }
+		else Just $ CredentialBaseURI $ u { uriPath = "" }

P2P/Http/Client.hs

@@ -17,6 +17,7 @@ import Types
 import Annex.Url
 
 #ifdef WITH_SERVANT
+import qualified Annex
 import Annex.UUID
 import Types.Remote
 import P2P.Http
@@ -35,6 +36,7 @@ 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
+import qualified Data.Map as M
 import Control.Concurrent.STM
 import Control.Concurrent.Async
 import Control.Concurrent
@@ -64,9 +66,14 @@ p2pHttpClient rmt fallback clientaction =
 		Just baseurl -> do
 			mgr <- httpManager <$> getUrlOptions
 			let clientenv = mkClientEnv mgr baseurl
-			go clientenv Nothing Nothing allProtocolVersions
+			ccv <- Annex.getRead Annex.gitcredentialcache
+			Git.CredentialCache cc <- liftIO $ atomically $
+				readTMVar ccv
+			case M.lookup (Git.CredentialBaseURL credentialbaseurl) cc of
+				Nothing -> go clientenv Nothing False Nothing allProtocolVersions
+				Just cred -> go clientenv (Just cred) True (credauth cred) allProtocolVersions
   where
-	go clientenv mcred mauth (v:vs) = do
+	go clientenv mcred credcached mauth (v:vs) = do
 		myuuid <- getUUID
 		res <- clientaction clientenv v
 			(B64UUID (uuid rmt))
@@ -75,11 +82,11 @@ p2pHttpClient rmt fallback clientaction =
 			mauth
 		case res of
 			Right resp -> do
-				maybe noop (\cred -> inRepo $ Git.approveUrlCredential cred) mcred
+				unless credcached $ cachecred mcred
 				return resp
 			Left (FailureResponse _ resp)
 				| statusCode (responseStatusCode resp) == 404 && not (null vs) ->
-					go clientenv mcred mauth vs
+					go clientenv mcred credcached mauth vs
 				| statusCode (responseStatusCode resp) == 401 ->
 					case mcred of
 						Nothing -> authrequired clientenv (v:vs)
@@ -93,28 +100,37 @@ p2pHttpClient rmt fallback clientaction =
 				_ -> 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 = 
+	authrequired clientenv vs = do
-		case p2pHttpUrlString <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
+		cred <- prompt $ 
-			Nothing -> error "internal"
+			inRepo $ Git.getUrlCredential credentialbaseurl
-			Just url -> do
+		go clientenv (Just cred) False (credauth cred) vs
-				cred <- prompt $
-					inRepo $ Git.getUrlCredential $
-						p2pHttpUrlWithoutUUID 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))
 
+	credentialbaseurl = case p2pHttpUrlString <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
+		Nothing -> error "internal"
+		Just url -> p2pHttpUrlWithoutUUID url
+
+	credauth cred = do
+		ba <- Git.credentialBasicAuth cred
+		return $ Auth
+			(encodeBS (basicAuthUser ba))
+			(encodeBS (basicAuthPassword ba))
+				
+	cachecred mcred = case mcred of
+		Just cred -> do
+			inRepo $ Git.approveUrlCredential cred
+			ccv <- Annex.getRead Annex.gitcredentialcache
+			liftIO $ atomically $ do
+				Git.CredentialCache cc <- takeTMVar ccv
+				putTMVar ccv $ Git.CredentialCache $
+					M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc
+		Nothing -> noop
 #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

doc/todo/git-annex_proxies.mdwn

@@ -28,8 +28,6 @@ Planned schedule of work:
 
 ## work notes
 
-* cache git credential auth
-
 * Rest of Remote.Git needs implementing.
 
 * git-annex p2phttp serving .well-known for ACME.