Authentication and dependencies.

README.md

@@ -42,10 +42,65 @@ credentials, SSH keys, pull strategy, and other repository configuration.
 ## Commands
 
 The package currently registers commands including `status`, `add`, `commit`,
-`push`, `pull`, `fetch`, `branch`, `switch`, `clone`, `tag`, `log`,
+`push`, `pull`, `fetch`, `config`, `branch`, `switch`, `clone`, `tag`, `log`,
 `rev-list`, `diff`, `show`, `grep`, `help`, `version`, and `new-version`.
 
 Most are also exported as direct procedures such as `git-status`, `git-add`,
-`git-fetch`, `git-switch`, `git-tag`, `git-log`, `git-diff`, and `git-show`.
+`git-fetch`, `git-config`, `git-switch`, `git-tag`, `git-log`, `git-diff`, and `git-show`.
 
 See the Scribble documentation for command-specific behavior and return values.
+
+## Git configuration
+
+`git config` has a small Racket-oriented interface:
+
+```racket
+(git 'config '--all)
+(git 'config 'get '--all)
+(git 'config '--global 'get '--all)
+(git 'config 'get '--global "user.email")
+(git 'config 'get '--all "credential.helper")
+(git 'config 'get "credential.helper")
+(git 'config 'set! "user.email" "hans@example.invalid")
+(git 'config '--global 'set! "user.email" "hans@example.invalid")
+(git 'config 'set! '--global "user.email" "hans@example.invalid")
+```
+
+`get --all` without a key returns `(key value)` items. `get --all key`
+returns all values for one key. `get key` returns one string or `#f` when the
+key is absent. `set!` returns `#t` after a successful write.
+
+## Low-level Git execution
+
+`run-git` can be used when direct access to Git's stdin/stdout protocol is
+needed. Optional text can be supplied to Git with `#:input`.
+
+```racket
+(run-git '(credential fill)
+         #:input "protocol=https\nhost=git.dijkewijk.nl\n\n")
+```
+
+The result remains two values: Git's exit code and the ordered
+`(source line)` output items.
+
+## Authentication retry
+
+Authentication failures are detected centrally after `run-git`, before
+command-specific result processing. `current-git-authentication-handler`
+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 custom credential handling.
+   #t))
+```
+

info.rkt

@@ -2,7 +2,7 @@
 
 (define collection "git-cli")
 (define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
-(define version "0.3.17")
+(define version "0.3.22")
 (define pkg-authors '("Hans Dijkema"))
 (define license 'MIT)
 
@@ -12,12 +12,12 @@
     "simple-log"
     "racket-index"
     "scribble-lib"
-    "racket-makefile"
+    ))
-    "package-zipper"))
 
 (define build-deps
   '("rackunit-lib"
     "racket-doc"))
 
 (define scribblings
-  '(("scribblings/git.scrbl" () ("Git"))))
+  '(("scribblings/git-cli.scrbl" () ("git-cli"))))
+

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
@@ -20,6 +20,7 @@
          git-fetch
          git-switch
          git-tag
+         git-config
          git-log
          git-grep
          git-branch
@@ -30,6 +31,14 @@
          git-help
          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
+         exn:fail:git-auth-args
+         exn:fail:git-auth-exit-code
+         exn:fail:git-auth-output
          (all-from-out "private/diff.rkt")
          )
 
@@ -116,6 +125,134 @@
                  (string-contains? line* "no changes added to commit"))))
          out))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Convert one git config --list output line to a key/value item.
+; pre    : line is one line produced by git config --list.
+; post   : line has only been inspected.
+; result : A list containing the configuration key and value.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (config-line->item line)
+  (let ((m (regexp-match #px"^([^=]+)=(.*)$" line)))
+    (if m
+        (list (cadr m) (caddr m))
+        (list line ""))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Translate the Racket-oriented config interface to git config arguments.
+; pre    : args starts with get or set! and follows one of the supported forms.
+; post   : info contains the config operation used to process Git's result.
+; result : Arguments accepted by git config.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-config-args args info)
+  (define (scope? x)
+    (member x '(--global --local --system)))
+
+  (define (split-scope args)
+    (cond
+      ((and (pair? args) (scope? (car args)))
+       (values (car args) (cdr args)))
+      (else
+       (values #f args))))
+
+  (let-values (((scope args*) (split-scope args)))
+    (cond
+      ;; Short form: (git 'config '--all)
+      ((and (not scope)
+            (= (length args*) 1)
+            (eq? (car args*) '--all))
+       (hash-set! info 'config-operation 'all)
+       '(--list))
+
+      ((null? args*)
+       (error 'git-config "Expected get or set!"))
+
+      (else
+       (let ((action (car args*))
+             (rest (cdr args*)))
+         (cond
+           ((eq? action 'get)
+            ;; Also accept scope directly after get.
+            (let-values (((scope* rest*) (split-scope rest)))
+              (let ((effective-scope (or scope scope*)))
+                (when (and scope scope*)
+                  (error 'git-config "Configuration scope specified twice"))
+                (cond
+                  ((null? rest*)
+                   (error 'git-config "Expected a configuration key or --all"))
+
+                  ((eq? (car rest*) '--all)
+                   (cond
+                     ((null? (cdr rest*))
+                      (hash-set! info 'config-operation 'all)
+                      (append (if effective-scope (list effective-scope) '())
+                              '(--list)))
+                     ((null? (cddr rest*))
+                      (hash-set! info 'config-operation 'get-all)
+                      (append (if effective-scope (list effective-scope) '())
+                              (list '--get-all (cadr rest*))))
+                     (else
+                      (error 'git-config "Too many arguments for config get --all"))))
+
+                  ((null? (cdr rest*))
+                   (hash-set! info 'config-operation 'get)
+                   (append (if effective-scope (list effective-scope) '())
+                           (list '--get (car rest*))))
+
+                  (else
+                   (error 'git-config "Too many arguments for config get"))))))
+
+           ((eq? action 'set!)
+            ;; Also accept scope directly after set!.
+            (let-values (((scope* rest*) (split-scope rest)))
+              (let ((effective-scope (or scope scope*)))
+                (when (and scope scope*)
+                  (error 'git-config "Configuration scope specified twice"))
+                (if (= (length rest*) 2)
+                    (begin
+                      (hash-set! info 'config-operation 'set)
+                      (append (if effective-scope (list effective-scope) '())
+                              rest*))
+                    (error 'git-config "Expected config set! [scope] key value")))))
+
+           (else
+            (error 'git-config "Expected get or set!"))))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Process the result of the Racket-oriented git config interface.
+; pre    : info contains the operation selected by git-config-args.
+; post   : Successful query output has been converted to Racket data.
+; result : Config data, #f for a missing single key, or #t after set!.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (process-git-config-result cmd exit-code result output out info)
+  (let* ((operation (hash-ref info 'config-operation))
+         (stdout (map cadr
+                      (filter (λ (entry) (eq? (car entry) 'stdout))
+                              output))))
+    (cond
+      ((eq? operation 'all)
+       (if (= exit-code 0)
+           (map config-line->item stdout)
+           (std-process-git-result cmd exit-code result output out info)))
+
+      ((eq? operation 'get-all)
+       (cond
+         ((= exit-code 0) stdout)
+         ((= exit-code 1) '())
+         (else
+          (std-process-git-result cmd exit-code result output out info))))
+
+      ((eq? operation 'get)
+       (cond
+         ((= exit-code 0)
+          (if (null? stdout) #f (car stdout)))
+         ((= exit-code 1) #f)
+         (else
+          (std-process-git-result cmd exit-code result output out info))))
+
+      (else
+       (std-process-git-result cmd exit-code result output out info)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Command definition macro
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -226,6 +363,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (def-cmd git-fetch cmd-git-fetch 'fetch)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Read or write Git configuration through a Racket-oriented interface.
+; pre    : Arguments follow one of the supported get/set! forms.
+; post   : Git config has completed or an exception has been raised.
+; result : Structured config data, #f for a missing key, or #t after set!.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-config cmd-git-config 'config
+  git-config-args
+  process-git-config-result)
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : List, create or delete branches.
@@ -586,11 +733,28 @@
   (when (null? args)
       (error "git-new-version expects 'maj, 'major, 'min, 'minor or 'patch"))
   (let ((kind (car args)))
-    (git-next-version kind ".")
+    (info-next-version kind ".")
     (git-version)))
 
 (hash-set! git-commands 'new-version cmd-git-new-version)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Implement the registered next-version command.
+; pre    : args must be empty. 
+; post   : The version definition in info.rkt has been updated.
+; result : The new patch version.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-next-version . args)
+  (cmd-git-next-version args))
+
+(define (cmd-git-next-version args)
+  (unless (null? args)
+    (error "git-next-version expexts no arguments"))
+  (let ((kind 'patch))
+    (info-next-version kind ".")
+    (git-version)))
+
+(hash-set! git-commands 'next-version cmd-git-next-version)
 
 
 

private/git-auth.rkt

@@ -0,0 +1,257 @@
+#lang racket/base
+
+(require racket/string
+         net/url
+         "git-provider.rkt"
+         "utils.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
+         default-git-authentication-handler
+         current-git-authentication-handler)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Authentication exception
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct exn:fail:git-auth exn:fail
+  (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.
+; post   : output has only been inspected.
+; result : #t when a known authentication failure is present, otherwise #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define auth-recognizers
+  '("authentication failed"
+    "failed to authenticate"
+    "could not read username"
+    "could not read password"
+    "http basic: access denied"
+    "access denied"
+    "terminal prompts disabled"
+    "requested url returned error: 401"
+    "requested url returned error: 403"
+    ))
+
+(define (authentication-failure? exit-code output)
+  (and (not (= exit-code 0))
+       (ormap
+        (λ (entry)
+          (let ((line (string-downcase (format "~a" (cadr entry)))))
+            (ormap (λ (x) (string-contains? line x)) auth-recognizers)))
+        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   : 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.
+; 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 default-git-authentication-handler))

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,13 @@
          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
+         exn:fail:git-auth-args
+         exn:fail:git-auth-exit-code
+         exn:fail:git-auth-output
          )
 
 
@@ -83,7 +91,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 +102,21 @@
        (let* ((args (flatten args*))
               (info (make-hash))
               (nargs (pre-code args 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))))))
+                 (process-result cmd exit-code result output out info))))))))
     )
   )

private/git-provider.rkt

@@ -88,11 +88,13 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Run Git without allowing interactive terminal prompts.
-; pre    : args contains the Git command and its arguments.
+; pre    : args contains the Git command and its arguments; input is #f or a string
-; post   : Standard output and error have been read completely.
+;          that must be written to Git's standard input.
+; post   : Optional input has been written and standard output and error have been
+;          read completely.
 ; result : The exit code and ordered (source line) output items.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (run-git args)
+(define (run-git args #:input (input #f))
   (putenv "GIT_TERMINAL_PROMPT" "0")
   (let-values (((process stdout stdin stderr)
                 (apply subprocess
@@ -102,6 +104,9 @@
                        (git-exe)
                        (map (λ (arg) (format "~a" arg)) args)
                        )))
+    (when input
+      (display input stdin)
+      (flush-output stdin))
     (close-output-port stdin)
     (let ((output-channel (make-channel)))
         (define (read-output source port)

private/info-handler.rkt

@@ -6,7 +6,7 @@
 
 (provide info-version
          set-info-version!
-         git-next-version
+         info-next-version
          )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -74,7 +74,7 @@
 ; post   : The version definition in info.rkt has been updated.
 ; result : #t after writing the new version.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (git-next-version kind . dir*)
+(define (info-next-version kind . dir*)
   (let ((dir (if (null? dir*)
                  "."
                  (car dir*))))

scribblings/git-cli.scrbl

@@ -19,7 +19,8 @@ read credentials or other answers from the terminal.
 Runs a registered Git @racket[command]. The arguments are passed to the command.
 Registered command symbols are @racket['status], @racket['add],
 @racket['commit], @racket['push], @racket['pull], @racket['fetch],
-@racket['branch], @racket['switch], @racket['clone], @racket['tag],
+@racket['config], @racket['branch], @racket['switch], @racket['clone],
+@racket['tag],
 @racket['log], @racket['rev-list], @racket['diff],
 @racket['show], @racket['grep], @racket['help], @racket['version], and
 @racket['new-version].
@@ -88,6 +89,51 @@ For example:
 ]
 }
 
+@defproc[(git-config [argument any/c] ...) any/c]{
+Provides a Racket-oriented interface to @tt{git config}. The same interface is
+available through @racket[git] with command @racket['config].
+
+@racketblock[
+(git 'config '--all)
+(git 'config 'get '--all)
+(git 'config '--global 'get '--all)
+(git 'config 'get '--global '--all)
+]
+
+returns all visible configuration entries as key/value items:
+
+@racketblock[
+'(("user.name" "Hans Dijkema")
+  ("user.email" "hans@example.invalid")
+  ("credential.helper" "manager"))
+]
+
+@racketblock[
+(git 'config 'get "credential.helper")
+]
+
+returns one value as a string, or @racket[#f] when the key is absent.
+
+@racketblock[
+(git 'config 'get '--all "credential.helper")
+]
+
+returns all values for one key as a list. An absent key produces the empty
+list.
+
+Configuration values can be written with @racket['set!]:
+
+@racketblock[
+(git 'config 'set! "user.email" "hans@example.invalid")
+(git 'config '--global 'set! "user.email" "hans@example.invalid")
+(git 'config 'set! '--global "user.email" "hans@example.invalid")
+]
+
+The optional scope can be @tt{--global}, @tt{--local}, or @tt{--system}. It may
+appear directly after @racket['config] or directly after @racket['get] /
+@racket['set!]. A successful write returns @racket[#t].
+}
+
 @defproc[(git-branch [argument any/c] ...) boolean?]{
 Runs @tt{git branch} with the supplied arguments. This can be used to list,
 create, rename, or delete branches according to the options supported by the
@@ -251,3 +297,87 @@ Updates the version in @filepath{info.rkt}. The kind is @racket['major],
 @racket['minor], or @racket['patch], with @racket['maj] and @racket['min] as
 abbreviations. The result is the new version as a list of three integers.
 }
+
+
+@section{Low-level Git execution}
+
+@defproc[(run-git [args list?]
+                  [#:input input (or/c #f string?) #f])
+         (values exact-integer? list?)]{
+Runs Git without interactive terminal prompts. When @racket[input] is a string,
+it is written to Git's standard input before that input port is closed.
+
+The procedure returns two values: Git's exit code and the ordered output items,
+where each item identifies either @racket['stdout] or @racket['stderr].
+
+@racketblock[
+(run-git '(credential fill)
+         #:input "protocol=https\nhost=git.dijkewijk.nl\n\n")
+]
+}
+
+@section{Authentication retry}
+
+Git commands recognize common authentication failures immediately after the
+Git process finishes and before command-specific result processing takes
+place. Such a failure is represented by @racket[exn:fail:git-auth?].
+
+@defparam[current-git-authentication-handler handler procedure?]{
+Controls the callback used when an authentication failure is detected. The
+callback receives the Git command symbol, the processed Git argument list and
+the @racket[exn:fail:git-auth] exception.
+
+The callback returns a true value when it has handled authentication and the
+original Git command should be tried again. A command is retried at most once.
+The default callback returns @racket[#f], preserving the normal Git error
+behavior.
+
+@racketblock[
+(current-git-authentication-handler
+ (lambda (cmd args e)
+   ;; Perform credential handling here.
+   #t))
+]
+}
+
+@defproc[(exn:fail:git-auth? [v any/c]) boolean?]{
+Recognizes the authentication exception used internally by git-cli.
+}
+
+@defproc[(exn:fail:git-auth-command [e exn:fail:git-auth?]) symbol?]{
+Returns the Git command of the failed invocation.
+}
+
+@defproc[(exn:fail:git-auth-args [e exn:fail:git-auth?]) list?]{
+Returns the processed Git arguments of the failed invocation.
+}
+
+@defproc[(exn:fail:git-auth-exit-code [e exn:fail:git-auth?]) exact-integer?]{
+Returns Git's exit code.
+}
+
+@defproc[(exn:fail:git-auth-output [e exn:fail:git-auth?]) list?]{
+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].
+}