122 lines
4.6 KiB
Racket
122 lines
4.6 KiB
Racket
#lang racket/base
|
|
|
|
(require "git-provider.rkt"
|
|
"git-auth.rkt"
|
|
racket/string
|
|
racket/list
|
|
)
|
|
|
|
(provide def-git-cmd-proxy
|
|
check-git-args
|
|
has-git-arg?
|
|
std-process-git-result
|
|
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
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Determine whether a Git option occurs in an argument list.
|
|
; pre : args is a list and opt is a symbol, string or regular expression.
|
|
; post : args has only been inspected.
|
|
; result : The match result, or #f when the option is absent.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (has-git-arg? args opt)
|
|
(let ((cmp (cond ((symbol? opt) (λ (x) (eq? x opt)))
|
|
((string? opt) (λ (x) (string=? (format "~a" x) opt)))
|
|
((regexp? opt) (λ (x) (regexp-match opt (format "~a" x))))
|
|
(else (error "opt must be a string, symbol or regular expression")))))
|
|
(letrec ((f (λ (args)
|
|
(if (null? args)
|
|
#f
|
|
(let ((m (cmp (car args))))
|
|
(if m
|
|
m
|
|
(f (cdr args))))))))
|
|
(if (list? args)
|
|
(f args)
|
|
(error 'has-git-arg? "args must be a list of arguments")))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Check that mandatory Git options and their arguments are present.
|
|
; pre : flags contains (option argument-count error-message) items.
|
|
; post : Missing options have raised an exception.
|
|
; result : args when every mandatory option is present.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (check-git-args cmd args flags)
|
|
(for-each
|
|
(λ (opt)
|
|
(let ((flag (car opt))
|
|
(num-args (cadr opt))
|
|
(err-msg (caddr opt)))
|
|
(letrec ((find (λ (l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? (car l) flag)
|
|
(if (>= (length (cdr l)) num-args)
|
|
#t
|
|
#f)
|
|
(find (cdr l)))))))
|
|
(let ((found (find args)))
|
|
(unless found
|
|
(error 'git (format "git ~a: ~a" cmd err-msg))))
|
|
)
|
|
))
|
|
flags)
|
|
args)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Process the standard result of a Git command.
|
|
; pre : exit-code and out belong to the completed Git command.
|
|
; post : Successful output has been displayed or a Git exception has been raised.
|
|
; result : #t when exit-code is zero.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (std-process-git-result cmd exit-code result output out info)
|
|
(if (= exit-code 0)
|
|
(begin
|
|
(git-displ (map cadr output))
|
|
#t)
|
|
(git-error cmd (format "Exitcode <> 0: ~a" exit-code) out)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Define the internal proxy for a Git command.
|
|
; pre : pre-code and process-result accept the command proxy arguments.
|
|
; 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
|
|
(syntax-rules ()
|
|
((_ f cmd pre-code process-result)
|
|
(define (f args*)
|
|
(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))))))))
|
|
)
|
|
)
|