Authentication handler in drracket

2026-08-13 19:13:58 +02:00
parent 12788edc7b
commit d3b5fdf830
7 changed files with 242 additions and 34 deletions
@@ -87,16 +87,20 @@ The result remains two values: Git's exit code and the ordered

 Authentication failures are detected centrally after `run-git`, before
 command-specific result processing. `current-git-authentication-handler`
-contains a callback that receives the command, processed arguments and an
-`exn:fail:git-auth` value. If the callback handles authentication and returns a
-true value, git-cli retries the original command once. The default callback
-returns `#f`, so existing error behavior is preserved until an authentication
-handler is configured.
+defaults to `default-git-authentication-handler`.
+
+The default handler first uses an existing Git `credential.helper`. When no
+helper is configured, it asks for username and password/token with
+`input-prompt`, configures the non-persistent `cache` helper locally, approves
+the credential through `git credential approve`, and retries the original Git
+command once.
+
+A custom handler can still be installed:

 ```racket
 (current-git-authentication-handler
 (λ (cmd args e)
-   ;; Perform credential handling here.
+   ;; Perform custom credential handling.
   #t))
 ```

@@ -1,23 +1,23 @@
-#lang info
-
-(define collection "git-cli")
-(define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
-(define version "0.3.19")
-(define pkg-authors '("Hans Dijkema"))
-(define license 'MIT)
-
-(define deps
-  '("base"
-    "simple-ini"
-    "simple-log"
-    "racket-index"
-    "scribble-lib"
-    "racket-makefile"
-    "package-zipper"))
-
-(define build-deps
-  '("rackunit-lib"
-    "racket-doc"))
-
-(define scribblings
-  '(("scribblings/git.scrbl" () ("Git"))))
+#lang info
+
+(define collection "git-cli")
+(define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
+(define version "0.3.21")
+(define pkg-authors '("Hans Dijkema"))
+(define license 'MIT)
+
+(define deps
+  '("base"
+    "simple-ini"
+    "simple-log"
+    "racket-index"
+    "scribble-lib"
+    "racket-makefile"
+    "package-zipper"))
+
+(define build-deps
+  '("rackunit-lib"
+    "racket-doc"))
+
+(define scribblings
+  '(("scribblings/git.scrbl" () ("Git"))))
@@ -4,7 +4,7 @@
         "private/git-commands.rkt"
         "private/config.rkt"
         "private/diff.rkt"
-         "private/info.rkt"
+         "private/info-handler.rkt"
         "private/utils.rkt"
         simple-log
         racket/string
@@ -32,6 +32,7 @@
         git-version
         git-new-version
         git-next-version
+         default-git-authentication-handler
         current-git-authentication-handler
         exn:fail:git-auth?
         exn:fail:git-auth-command
@@ -1,7 +1,9 @@
 #lang racket/base

 (require racket/string
-         "git-provider.rkt")
+         net/url
+         "git-provider.rkt"
+         "utils.rkt")

 (provide exn:fail:git-auth?
         exn:fail:git-auth-command
@@ -10,6 +12,7 @@
         exn:fail:git-auth-output
         authentication-failure?
         raise-git-auth-error
+         default-git-authentication-handler
         current-git-authentication-handler)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -20,6 +23,166 @@
  (command args exit-code output)
  #:transparent)

+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Supporting functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Read the first value of a Git configuration key.
+; pre    : key is a Git configuration key.
+; post   : Git config has been queried without displaying its output.
+; result : The configured value, or #f when the key is absent.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-config-value key)
+  (let-values (((exit-code output)
+                (run-git (list 'config '--get key))))
+    (if (= exit-code 0)
+        (let ((stdout
+               (map cadr
+                    (filter (λ (entry) (eq? (car entry) 'stdout))
+                            output))))
+          (if (null? stdout) #f (car stdout)))
+        #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Determine the remote name used by the current branch.
+; pre    : The current directory is a Git working tree.
+; post   : Git branch/config have only been queried.
+; result : The configured remote name, or "origin" as fallback.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-current-remote)
+  (let-values (((exit-code output)
+                (run-git '(branch --show-current))))
+    (if (= exit-code 0)
+        (let ((stdout
+               (map cadr
+                    (filter (λ (entry) (eq? (car entry) 'stdout))
+                            output))))
+          (if (null? stdout)
+              "origin"
+              (let ((remote
+                     (git-config-value
+                      (format "branch.~a.remote" (car stdout)))))
+                (if remote remote "origin"))))
+        "origin")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Determine the remote URL relevant to the failed Git command.
+; pre    : cmd and args belong to a failed authenticated Git command.
+; post   : Git config has only been queried.
+; result : An HTTP(S) remote URL, or #f when it cannot be determined.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-authentication-url cmd args)
+  (let* ((remote (git-current-remote))
+         (url (git-config-value (format "remote.~a.url" remote))))
+    (if url
+        url
+        (git-config-value "remote.origin.url"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Convert an HTTP(S) remote URL to Git credential input.
+; pre    : value is a URL string.
+; post   : value has only been parsed.
+; result : protocol, host and optional username, or #f values for unsupported URLs.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (url->credential-parts value)
+  (with-handlers ((exn:fail? (λ (e) (values #f #f #f))))
+    (let* ((u (string->url value))
+           (protocol (url-scheme u))
+           (host (url-host u))
+           (user (url-user u)))
+      (if (and (member protocol '("http" "https"))
+               (string? host)
+               (not (string=? host "")))
+          (values protocol host user)
+          (values #f #f #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Build Git credential protocol input.
+; pre    : protocol and host are strings; username and password may be #f.
+; post   : Arguments have only been formatted.
+; result : A credential protocol string terminated by a blank line.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (credential-input protocol host username password)
+  (string-append
+   (format "protocol=~a\n" protocol)
+   (format "host=~a\n" host)
+   (if username (format "username=~a\n" username) "")
+   (if password (format "password=~a\n" password) "")
+   "\n"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Ask Git's configured credential helper for credentials.
+; pre    : protocol and host identify the failed HTTP(S) remote.
+; post   : The helper may have prompted or updated its own credential state.
+; result : #t when git credential fill succeeded, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-credential-fill protocol host username)
+  (let-values (((exit-code output)
+                (run-git '(credential fill)
+                         #:input (credential-input protocol host username #f))))
+    (= exit-code 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Offer credentials to Git's configured credential helper.
+; pre    : protocol, host, username and password describe a credential.
+; post   : Git credential approve has been invoked.
+; result : #t when Git accepted the approve operation, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-credential-approve protocol host username password)
+  (let-values (((exit-code output)
+                (run-git '(credential approve)
+                         #:input (credential-input protocol host username password))))
+    (= exit-code 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Ensure a non-persistent credential helper exists for this repository.
+; pre    : The current directory is inside a Git working tree.
+; post   : credential.helper=cache is configured locally when no helper existed.
+; result : #t when a helper exists or was configured, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (ensure-credential-helper)
+  (let ((helper (git-config-value "credential.helper")))
+    (if helper
+        #t
+        (let-values (((exit-code output)
+                      (run-git '(config --local credential.helper cache))))
+          (= exit-code 0)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Ask the user for credentials and approve them through Git.
+; pre    : protocol and host identify an HTTP(S) remote.
+; 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
+              username
+              (input-prompt
+               (format "Username for ~a: " host)
+               #:loop-until
+               (λ (value)
+                 (if (and (string? value)
+                          (not (string=? (string-trim value) "")))
+                     (string-trim value)
+                     #f)))))
+         (password
+          (input-prompt
+           (format "Password/token for ~a: " host)
+           #:loop-until
+           (λ (value)
+             (if (and (string? value)
+                      (not (string=? value "")))
+                 value
+                 #f)))))
+    (and (ensure-credential-helper)
+         (git-credential-approve protocol host username* password))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Authentication handling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Recognize output that indicates Git authentication failed.
 ; pre    : exit-code and output belong to a completed Git command.
@@ -55,6 +218,27 @@
                        exit-code
                        output))))

+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Resolve an authentication failure using Git first, then input-prompt.
+; pre    : cmd, args and e describe one failed Git invocation.
+; post   : Git's helper has been tried; a missing helper may be configured locally.
+; result : #t when retrying the original command is meaningful, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (default-git-authentication-handler cmd args e)
+  (let ((url (git-authentication-url cmd args)))
+    (if (not url)
+        #f
+        (let-values (((protocol host username)
+                      (url->credential-parts url)))
+          (if (not protocol)
+              #f
+              (let ((helper (git-config-value "credential.helper")))
+                (if (and helper
+                         (git-credential-fill protocol host username))
+                    #t
+                    (ask-and-approve-credential
+                     protocol host username))))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Supply the callback that can resolve an authentication failure.
 ; pre    : The callback accepts command, arguments and an exn:fail:git-auth value.
@@ -62,6 +246,4 @@
 ; result : A parameter containing the current authentication callback.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define current-git-authentication-handler
-  (make-parameter
-   (λ (cmd args e)
-     #f)))
+  (make-parameter default-git-authentication-handler))
@@ -10,6 +10,7 @@
         check-git-args
         has-git-arg?
         std-process-git-result
+         default-git-authentication-handler
         current-git-authentication-handler
         exn:fail:git-auth?
         exn:fail:git-auth-command
@@ -361,3 +361,23 @@ Returns the ordered @racket['stdout]/@racket['stderr] output items from the
 failed Git process.
 }

+
+
+@section{Authentication}
+
+@defproc[(default-git-authentication-handler
+          [cmd symbol?]
+          [args list?]
+          [e exn:fail:git-auth?])
+         boolean?]{
+Handles one authentication failure. An existing Git credential helper is tried
+first. If no helper is configured, git-cli requests a username and
+password/token using @racket[input-prompt], configures Git's non-persistent
+@tt{cache} credential helper locally, approves the credential, and returns
+@racket[#t] so the original command can be retried once.
+}
+
+@defparam[current-git-authentication-handler handler procedure?]{
+Contains the authentication callback used after a recognized authentication
+failure. Its default value is @racket[default-git-authentication-handler].
+}