Authentication

README.md

@@ -85,22 +85,25 @@ The result remains two values: Git's exit code and the ordered
 
 ## Authentication retry
 
-Authentication failures are detected centrally after `run-git`, before
+Authentication failures are recognized centrally after `run-git`. The
-command-specific result processing. `current-git-authentication-handler`
+recognizer covers common authentication/authorization errors, including HTTP
-defaults to `default-git-authentication-handler`.
+401 and 403 responses.
 
-The default handler first uses an existing Git `credential.helper`. When no
+`current-git-authentication-handler` defaults to
-helper is configured, it asks for username and password/token with
+`default-git-authentication-handler`. After an authentication failure the
-`input-prompt`, configures the non-persistent `cache` helper locally, approves
+default handler rejects the failed credential first. If a Git credential
-the credential through `git credential approve`, and retries the original Git
+helper exists, `git credential fill` is then tried so that helpers such as Git
-command once.
+Credential Manager can obtain a replacement credential.
 
-A custom handler can still be installed:
+When no usable credential is returned, git-cli asks for a username and
+password/token using `input-prompt`. The `#:loop-until` callbacks validate the
+input and return the final value, as intended by `input-prompt`. If no
+credential helper is configured, git-cli configures the non-persistent `cache`
+helper locally before approving the supplied credential.
 
-```racket
+The original Git command is retried once. If authentication fails again, the
-(current-git-authentication-handler
+credential used for that retry is rejected before the normal Git error is
- (λ (cmd args e)
+raised. This prevents a bad token from remaining in the credential cache.
-   ;; Perform custom credential handling.
-   #t))
-```
 
+A custom handler can still be installed through
+`current-git-authentication-handler`.

info.rkt

@@ -2,7 +2,7 @@
 
 (define collection "git-cli")
 (define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
-(define version "0.3.22")
+(define version "0.3.23")
 (define pkg-authors '("Hans Dijkema"))
 (define license 'MIT)
 

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)
+                 (cond
-                          (not (string=? (string-trim value) "")))
+                   ((eof-object? value)
-                     (string-trim value)
+                    (error 'git-authentication "Input cancelled"))
-                     #f)))))
+                   ((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)
+             (cond
-                      (not (string=? value "")))
+               ((eof-object? value)
-                 value
+                (error 'git-authentication "Input cancelled"))
-                 #f)))))
+               ((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
+(define auth-recognizer
-  '("authentication failed"
+  #px"(authentication failed|failed to authenticate|could not read (username|password)|access denied|terminal prompts disabled|requested url returned error: (401|403))")
-    "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 (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?
+                   (if authentication-retry?
-                            ((current-git-authentication-handler) cmd nargs e))
+                       (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))))))
+                                      (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

scribblings/git-cli.scrbl

@@ -329,8 +329,7 @@ the @racket[exn:fail:git-auth] exception.
 
 The callback returns a true value when it has handled authentication and the
 original Git command should be tried again. A command is retried at most once.
-The default callback returns @racket[#f], preserving the normal Git error
+The default callback is @racket[default-git-authentication-handler].
-behavior.
 
 @racketblock[
 (current-git-authentication-handler
@@ -370,11 +369,14 @@ failed Git process.
           [args list?]
           [e exn:fail:git-auth?])
          boolean?]{
-Handles one authentication failure. An existing Git credential helper is tried
+Handles one authentication failure. A credential that already failed is first
-first. If no helper is configured, git-cli requests a username and
+rejected. An existing Git credential helper is then asked for a replacement
-password/token using @racket[input-prompt], configures Git's non-persistent
+credential. If that does not succeed, git-cli requests a username and
-@tt{cache} credential helper locally, approves the credential, and returns
+password/token using @racket[input-prompt]. Its @racket[#:loop-until] callbacks
-@racket[#t] so the original command can be retried once.
+both validate the input and return the value that is used. If no helper is
+configured, Git's non-persistent @tt{cache} helper is configured locally before
+the credential is approved. The original command is retried once; a credential
+that fails on the retry is rejected before the Git error is raised.
 }
 
 @defparam[current-git-authentication-handler handler procedure?]{