From d3b5fdf830219ad0fa057bf3d9122dc7e2192176 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Thu, 13 Aug 2026 19:13:58 +0200 Subject: [PATCH] Authentication handler in drracket --- README.md | 16 ++- info.rkt | 46 +++--- main.rkt | 3 +- private/git-auth.rkt | 190 ++++++++++++++++++++++++- private/git-commands.rkt | 1 + private/{info.rkt => info-handler.rkt} | 0 scribblings/git.scrbl | 20 +++ 7 files changed, 242 insertions(+), 34 deletions(-) rename private/{info.rkt => info-handler.rkt} (100%) diff --git a/README.md b/README.md index ea47b65..47ec2fd 100644 --- a/README.md +++ b/README.md @@ -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)) ``` diff --git a/info.rkt b/info.rkt index ce6da00..0d0fc5c 100644 --- a/info.rkt +++ b/info.rkt @@ -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")))) \ No newline at end of file +#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")))) diff --git a/main.rkt b/main.rkt index 46c30a5..d6f83ef 100644 --- a/main.rkt +++ b/main.rkt @@ -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 diff --git a/private/git-auth.rkt b/private/git-auth.rkt index 518094c..1f1888d 100644 --- a/private/git-auth.rkt +++ b/private/git-auth.rkt @@ -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)) diff --git a/private/git-commands.rkt b/private/git-commands.rkt index 01eff0d..780b30f 100644 --- a/private/git-commands.rkt +++ b/private/git-commands.rkt @@ -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 diff --git a/private/info.rkt b/private/info-handler.rkt similarity index 100% rename from private/info.rkt rename to private/info-handler.rkt diff --git a/scribblings/git.scrbl b/scribblings/git.scrbl index 27e8cf0..81e9d18 100644 --- a/scribblings/git.scrbl +++ b/scribblings/git.scrbl @@ -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]. +}