First implementation of authentication handling

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))))))))
     )
   )