Authentication

private/git-auth.rkt

@@ -13,6 +13,7 @@
          authentication-failure?
          raise-git-auth-error
          default-git-authentication-handler
+         reject-git-authentication
          current-git-authentication-handler)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -135,6 +136,18 @@
                          #:input (credential-input protocol host username password))))
     (= exit-code 0)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Reject credentials for an HTTP(S) remote through Git.
+; pre    : protocol and host identify the credential; username may be #f.
+; post   : Git credential reject has been invoked.
+; result : #t when Git accepted the reject operation, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-credential-reject protocol host username)
+  (let-values (((exit-code output)
+                (run-git '(credential reject)
+                         #:input (credential-input protocol host username #f))))
+    (= exit-code 0)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Ensure a non-persistent credential helper exists for this repository.
 ; pre    : The current directory is inside a Git working tree.
@@ -155,6 +168,7 @@
 ; post   : Supplied credentials have been offered to Git's helper.
 ; result : #t when credentials were approved, otherwise #f.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (define (ask-and-approve-credential protocol host username)
   (let* ((username*
           (if username
@@ -163,22 +177,29 @@
                (format "Username for ~a: " host)
                #:loop-until
                (λ (value)
-                 (if (and (string? value)
-                          (not (string=? (string-trim value) "")))
-                     (string-trim value)
-                     #f)))))
+                 (cond
+                   ((eof-object? value)
+                    (error 'git-authentication "Input cancelled"))
+                   ((string=? (string-trim value) "")
+                    #f)
+                   (else
+                    (string-trim value)))))))
          (password
           (input-prompt
            (format "Password/token for ~a: " host)
            #:loop-until
            (λ (value)
-             (if (and (string? value)
-                      (not (string=? value "")))
-                 value
-                 #f)))))
+             (cond
+               ((eof-object? value)
+                (error 'git-authentication "Input cancelled"))
+               ((string=? value "")
+                #f)
+               (else
+                value))))))
     (and (ensure-credential-helper)
          (git-credential-approve protocol host username* password))))
 
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Authentication handling
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -190,24 +211,15 @@
 ; result : #t when a known authentication failure is present, otherwise #f.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define auth-recognizers
-  '("authentication failed"
-    "failed to authenticate"
-    "could not read username"
-    "could not read password"
-    "http basic: access denied"
-    "access denied"
-    "terminal prompts disabled"
-    "requested url returned error: 401"
-    "requested url returned error: 403"
-    ))
+(define auth-recognizer
+  #px"(authentication failed|failed to authenticate|could not read (username|password)|access denied|terminal prompts disabled|requested url returned error: (401|403))")
 
 (define (authentication-failure? exit-code output)
   (and (not (= exit-code 0))
        (ormap
         (λ (entry)
           (let ((line (string-downcase (format "~a" (cadr entry)))))
-            (ormap (λ (x) (string-contains? line x)) auth-recognizers)))
+            (regexp-match? auth-recognizer line)))
         output)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -226,6 +238,22 @@
                         exit-code
                         output))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Reject the credential associated with a failed Git command.
+; pre    : cmd and args identify a failed authenticated Git invocation.
+; post   : Git's credential helper has been asked to forget the credential.
+; result : #t when a credential could be identified and rejected, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (reject-git-authentication cmd args)
+  (let ((url (git-authentication-url cmd args)))
+    (if (not url)
+        #f
+        (let-values (((protocol host username)
+                      (url->credential-parts url)))
+          (if protocol
+              (git-credential-reject protocol host username)
+              #f)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Resolve an authentication failure using Git first, then input-prompt.
 ; pre    : cmd, args and e describe one failed Git invocation.
@@ -241,6 +269,8 @@
           (if (not protocol)
               #f
               (let ((helper (git-config-value "credential.helper")))
+                (when helper
+                  (git-credential-reject protocol host username))
                 (if (and helper
                          (git-credential-fill protocol host username))
                     #t