First implementation of authentication handling

2026-08-13 17:03:48 +02:00
parent c90c407dce
commit 73084e69d9
6 changed files with 162 additions and 5 deletions
@@ -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)))