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

private/git-commands.rkt

@@ -106,13 +106,19 @@
            (with-handlers
                ((exn:fail:git-auth?
                  (λ (e)
-                   (if (and authentication-retry?
-                            ((current-git-authentication-handler) cmd nargs e))
-                       (retry #f)
-                       (git-error cmd
-                                  (format "Exitcode <> 0: ~a"
-                                          (exn:fail:git-auth-exit-code e))
-                                  (exn:fail:git-auth-output e))))))
+                   (if authentication-retry?
+                       (if ((current-git-authentication-handler) cmd nargs e)
+                           (retry #f)
+                           (git-error cmd
+                                      (format "Exitcode <> 0: ~a"
+                                              (exn:fail:git-auth-exit-code e))
+                                      (exn:fail:git-auth-output e)))
+                       (begin
+                         (reject-git-authentication cmd nargs)
+                         (git-error cmd
+                                    (format "Exitcode <> 0: ~a"
+                                            (exn:fail:git-auth-exit-code e))
+                                    (exn:fail:git-auth-output e)))))))
              (let-values (((exit-code output) (run-git (cons cmd nargs))))
                (when (authentication-failure? exit-code output)
                  (raise-git-auth-error cmd nargs exit-code output))

private/utils.rkt

@@ -6,6 +6,24 @@
          valid-http-or-file-url?
          )
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Ask the user for input .
+; pre    : p is a prompt.
+; post   : It should give back the supplied input as string.
+; result : the return value of until.
+; internals:
+;
+; input-prompt displays the given prompt and reads a line
+; of text. After the user presses enter, this line is
+; fed to the until callback. If the until callback returns
+; #f, the prompt is displayed again. Otherwise, the value
+; of until is returned.
+;
+; The programmer must make sure the until returns whatever
+; format is appropriate. In general it will be a string. 
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (define (input-prompt p #:loop-until [until (λ (x) x)])
   (let loop ()
     (display p)
@@ -20,7 +38,6 @@
   )
 
 
-
 (define (valid-http-or-file-url? value)
   (if (not (string? value))
       #f