258 lines
11 KiB
Racket
258 lines
11 KiB
Racket
#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))
|