First implementation of authentication handling

private/git-auth.rkt

@@ -0,0 +1,67 @@
+#lang racket/base
+
+(require racket/string
+         "git-provider.rkt")
+
+(provide exn:fail:git-auth?
+         exn:fail:git-auth-command
+         exn:fail:git-auth-args
+         exn:fail:git-auth-exit-code
+         exn:fail:git-auth-output
+         authentication-failure?
+         raise-git-auth-error
+         current-git-authentication-handler)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Authentication exception
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct exn:fail:git-auth exn:fail
+  (command args exit-code output)
+  #:transparent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Recognize output that indicates Git authentication failed.
+; pre    : exit-code and output belong to a completed Git command.
+; post   : output has only been inspected.
+; result : #t when a known authentication failure is present, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (authentication-failure? exit-code output)
+  (and (not (= exit-code 0))
+       (ormap
+        (λ (entry)
+          (let ((line (string-downcase (format "~a" (cadr entry)))))
+            (or (string-contains? line "authentication failed")
+                (string-contains? line "failed to authenticate")
+                (string-contains? line "could not read username")
+                (string-contains? line "could not read password")
+                (string-contains? line "http basic: access denied")
+                (string-contains? line "terminal prompts disabled"))))
+        output)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Raise a Git authentication exception containing the failed invocation.
+; pre    : cmd, args, exit-code and output describe a failed Git command.
+; post   : An exn:fail:git-auth exception has been raised.
+; result : No normal return value.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (raise-git-auth-error cmd args exit-code output)
+  (let ((msg (format "git ~a: authentication failed" cmd)))
+    (raise
+     (exn:fail:git-auth msg
+                        (current-continuation-marks)
+                        cmd
+                        args
+                        exit-code
+                        output))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Supply the callback that can resolve an authentication failure.
+; pre    : The callback accepts command, arguments and an exn:fail:git-auth value.
+; post   : The callback is used by command proxies before one authentication retry.
+; result : A parameter containing the current authentication callback.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define current-git-authentication-handler
+  (make-parameter
+   (λ (cmd args e)
+     #f)))

private/git-commands.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require "git-provider.rkt"
+         "git-auth.rkt"
          racket/string
          racket/list
          )
@@ -9,6 +10,12 @@
          check-git-args
          has-git-arg?
          std-process-git-result
+         current-git-authentication-handler
+         exn:fail:git-auth?
+         exn:fail:git-auth-command
+         exn:fail:git-auth-args
+         exn:fail:git-auth-exit-code
+         exn:fail:git-auth-output
          )
 
 
@@ -83,7 +90,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Define the internal proxy for a Git command.
 ; pre    : pre-code and process-result accept the command proxy arguments.
-; post   : The proxy invokes Git without standard input and processes its result.
+; post   : Authentication failures are offered once to the current authentication
+;          handler before the Git command is retried.
 ; result : A procedure named f accepting a list of Git arguments.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define-syntax def-git-cmd-proxy
@@ -93,8 +101,21 @@
        (let* ((args (flatten args*))
               (info (make-hash))
               (nargs (pre-code args info)))
-         (let-values (((exit-code output) (run-git (cons cmd nargs))))
-           (let-values (((result out) (git-out cmd output)))
-             (process-result cmd exit-code result output out info))))))
+         (let retry ((authentication-retry? #t))
+           (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))))))
+             (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))
+               (let-values (((result out) (git-out cmd output)))
+                 (process-result cmd exit-code result output out info))))))))
     )
   )