better handling for reporting on callbacks from c library
This commit is contained in:
@@ -1,6 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
(require ffi/unsafe
|
||||
racket/async-channel
|
||||
racket/list
|
||||
racket/match
|
||||
racket/path
|
||||
@@ -8,8 +9,6 @@
|
||||
"credentials.rkt"
|
||||
libgit2)
|
||||
|
||||
; Again.
|
||||
|
||||
(provide git
|
||||
dgit
|
||||
git-repository?
|
||||
@@ -96,7 +95,16 @@
|
||||
[else GIT-PASSTHROUGH])])))
|
||||
|
||||
(define (set-credential-callback! callbacks)
|
||||
(set-git_remote_callbacks-credentials! callbacks git-credential-callback)
|
||||
;; A blocking libgit2 callout may dispatch this callback to another Racket
|
||||
;; thread. Preserve the caller's credential-store parameterization there.
|
||||
(define credentials-store (current-git-credentials-store))
|
||||
(define unlock-store (current-git-credentials-unlock-store))
|
||||
(set-git_remote_callbacks-credentials!
|
||||
callbacks
|
||||
(lambda args
|
||||
(parameterize ([current-git-credentials-store credentials-store]
|
||||
[current-git-credentials-unlock-store unlock-store])
|
||||
(apply git-credential-callback args))))
|
||||
callbacks)
|
||||
|
||||
(define (progress-message quiet format-string . args)
|
||||
@@ -105,25 +113,112 @@
|
||||
(newline)
|
||||
(flush-output)))
|
||||
|
||||
(define (make-progress-reporter label quiet #:bytes? [bytes? #t])
|
||||
(define (progress-phase-name phase)
|
||||
(case phase
|
||||
[(1) "packing"]
|
||||
[(2) "compressing"]
|
||||
[(3) "sending"]
|
||||
[else #f]))
|
||||
|
||||
(define (make-progress-reporter label quiet #:bytes? [bytes? #t] #:phase? [phase? #f])
|
||||
(define last-phase -1)
|
||||
(define last-percent -10)
|
||||
(lambda (current total bytes)
|
||||
(lambda (phase current total bytes)
|
||||
(unless (or quiet (zero? total))
|
||||
(when (not (= phase last-phase))
|
||||
(set! last-phase phase)
|
||||
(set! last-percent -10))
|
||||
(define percent
|
||||
(min 100 (quotient (* current 100) total)))
|
||||
(when (and (positive? current)
|
||||
(or (>= (- percent last-percent) 10)
|
||||
(= current total)))
|
||||
(set! last-percent percent)
|
||||
(if bytes?
|
||||
(progress-message
|
||||
#f
|
||||
"[git] ~a: ~a% (~a/~a objects, ~a KiB)"
|
||||
label percent current total (quotient (+ bytes 1023) 1024))
|
||||
(progress-message
|
||||
#f
|
||||
"[git] ~a: ~a% (~a/~a objects)"
|
||||
label percent current total))))))
|
||||
(define phase-name (and phase? (progress-phase-name phase)))
|
||||
(cond
|
||||
[(and phase-name bytes?)
|
||||
(progress-message
|
||||
#f
|
||||
"[git] ~a: ~a ~a% (~a/~a objects, ~a KiB)"
|
||||
label phase-name percent current total (quotient (+ bytes 1023) 1024))]
|
||||
[phase-name
|
||||
(progress-message
|
||||
#f
|
||||
"[git] ~a: ~a ~a% (~a/~a objects)"
|
||||
label phase-name percent current total)]
|
||||
[bytes?
|
||||
(progress-message
|
||||
#f
|
||||
"[git] ~a: ~a% (~a/~a objects, ~a KiB)"
|
||||
label percent current total (quotient (+ bytes 1023) 1024))]
|
||||
[else
|
||||
(progress-message
|
||||
#f
|
||||
"[git] ~a: ~a% (~a/~a objects)"
|
||||
label percent current total)])))))
|
||||
|
||||
;; Progress callbacks must never perform I/O. For blocking libgit2 callouts the
|
||||
;; binding dispatches them to a safe Racket callback thread; they only update
|
||||
;; this pre-allocated state. A separate ordinary Racket thread performs output.
|
||||
(define (make-progress-state)
|
||||
;; phase, current, total, bytes
|
||||
(vector 0 0 0 0))
|
||||
|
||||
(define (progress-state-set! state phase current total bytes)
|
||||
(vector-set! state 0 phase)
|
||||
(vector-set! state 1 current)
|
||||
(vector-set! state 2 total)
|
||||
(vector-set! state 3 bytes))
|
||||
|
||||
(define (progress-state-ref state)
|
||||
(values (vector-ref state 0)
|
||||
(vector-ref state 1)
|
||||
(vector-ref state 2)
|
||||
(vector-ref state 3)))
|
||||
|
||||
(define (report-progress-snapshot report state)
|
||||
(define-values (phase current total bytes)
|
||||
(progress-state-ref state))
|
||||
(report phase current total bytes))
|
||||
|
||||
(define (call-with-progress label quiet state thunk
|
||||
#:bytes? [bytes? #t]
|
||||
#:phase? [phase? #f])
|
||||
;; Run the blocking libgit2 operation in its own parallel Racket thread.
|
||||
;; The caller remains a normal coroutine thread and is therefore free to
|
||||
;; update DrRacket/console output. libgit2 callbacks are dispatched back to
|
||||
;; a safe ordinary Racket thread by the libgit2 binding.
|
||||
(define result-channel (make-async-channel))
|
||||
(define report
|
||||
(and (not quiet)
|
||||
(make-progress-reporter label #f #:bytes? bytes? #:phase? phase?)))
|
||||
(thread
|
||||
#:pool 'own
|
||||
(lambda ()
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(async-channel-put result-channel
|
||||
(cons 'error e)))])
|
||||
(call-with-values
|
||||
thunk
|
||||
(lambda results
|
||||
(async-channel-put result-channel (cons 'ok results)))))))
|
||||
(define (return-result result)
|
||||
(when report
|
||||
(report-progress-snapshot report state))
|
||||
(case (car result)
|
||||
[(ok) (apply values (cdr result))]
|
||||
[(error) (raise (cdr result))]))
|
||||
(cond
|
||||
[quiet
|
||||
(return-result (sync result-channel))]
|
||||
[else
|
||||
(let loop ()
|
||||
(define result (sync/timeout 0.1 result-channel))
|
||||
(cond
|
||||
[result (return-result result)]
|
||||
[else
|
||||
(report-progress-snapshot report state)
|
||||
(loop)]))]))
|
||||
|
||||
(define (transfer-progress-total-objects stats)
|
||||
(ptr-ref stats _uint 0))
|
||||
@@ -135,55 +230,62 @@
|
||||
;; git_transfer_progress has six unsigned-int fields followed by size_t.
|
||||
(ptr-ref (ptr-add stats (* 6 (ctype-sizeof _uint))) _size))
|
||||
|
||||
(define (set-fetch-progress-callback! callbacks label quiet)
|
||||
(define report (make-progress-reporter label quiet))
|
||||
(define (set-fetch-progress-callback! callbacks state)
|
||||
(set-git_remote_callbacks-transfer_progress!
|
||||
callbacks
|
||||
(lambda (stats _payload)
|
||||
(report (transfer-progress-received-objects stats)
|
||||
(transfer-progress-total-objects stats)
|
||||
(transfer-progress-received-bytes stats))
|
||||
(progress-state-set!
|
||||
state 0
|
||||
(transfer-progress-received-objects stats)
|
||||
(transfer-progress-total-objects stats)
|
||||
(transfer-progress-received-bytes stats))
|
||||
0))
|
||||
callbacks)
|
||||
|
||||
(define (set-push-progress-callback! callbacks _label _quiet)
|
||||
;; Diagnostic 0.2.7a: keep the libgit2 push progress callback installed,
|
||||
;; but do no Racket I/O (or other synchronization) from callback context.
|
||||
;; Racket CS runs FFI callbacks in atomic mode; writing to DrRacket's output
|
||||
;; port from here can therefore crash the process during a real push.
|
||||
(define (set-push-progress-callback! callbacks state)
|
||||
(set-git_remote_callbacks-pack_progress!
|
||||
callbacks
|
||||
(lambda (stage current total _payload)
|
||||
;; 0 = adding objects, 1 = deltafication in libgit2 1.4.
|
||||
(progress-state-set! state (if (zero? stage) 1 2) current total 0)
|
||||
0))
|
||||
(set-git_remote_callbacks-push_transfer_progress!
|
||||
callbacks
|
||||
(lambda (_current _total _bytes _payload)
|
||||
(lambda (current total bytes _payload)
|
||||
(progress-state-set! state 3 current total bytes)
|
||||
0))
|
||||
callbacks)
|
||||
|
||||
(define (make-fetch-options label quiet)
|
||||
(define (make-fetch-options)
|
||||
(define state (make-progress-state))
|
||||
(define options
|
||||
(cast (malloc _git_fetch_opts 'atomic) _pointer _git_fetch_opts-pointer))
|
||||
(cast (malloc _git_fetch_opts 'atomic-interior) _pointer _git_fetch_opts-pointer))
|
||||
(git_fetch_options_init options GIT_FETCH_OPTS_VERSION)
|
||||
(define callbacks (git_fetch_opts-callbacks options))
|
||||
(set-credential-callback! callbacks)
|
||||
(set-fetch-progress-callback! callbacks label quiet)
|
||||
options)
|
||||
(set-fetch-progress-callback! callbacks state)
|
||||
(values options state))
|
||||
|
||||
(define (make-push-options label quiet)
|
||||
(define (make-push-options)
|
||||
(define state (make-progress-state))
|
||||
(define options
|
||||
(cast (malloc _git_push_opts 'atomic) _pointer _git_push_opts-pointer))
|
||||
(cast (malloc _git_push_opts 'atomic-interior) _pointer _git_push_opts-pointer))
|
||||
(git_push_options_init options GIT_PUSH_OPTS_VERSION)
|
||||
(define callbacks (git_push_opts-callbacks options))
|
||||
(set-credential-callback! callbacks)
|
||||
(set-push-progress-callback! callbacks label quiet)
|
||||
options)
|
||||
(set-push-progress-callback! callbacks state)
|
||||
(values options state))
|
||||
|
||||
(define (make-clone-options label quiet)
|
||||
(define (make-clone-options)
|
||||
(define state (make-progress-state))
|
||||
(define options
|
||||
(cast (malloc _git_clone_opts 'atomic) _pointer _git_clone_opts-pointer))
|
||||
(cast (malloc _git_clone_opts 'atomic-interior) _pointer _git_clone_opts-pointer))
|
||||
(git_clone_options_init options GIT_CLONE_OPTS_VERSION)
|
||||
(define callbacks
|
||||
(git_fetch_opts-callbacks (git_clone_opts-fetch_opts options)))
|
||||
(set-credential-callback! callbacks)
|
||||
(set-fetch-progress-callback! callbacks label quiet)
|
||||
options)
|
||||
(set-fetch-progress-callback! callbacks state)
|
||||
(values options state))
|
||||
|
||||
(define (blank-oid)
|
||||
(git_oid_fromstr zero-oid-string))
|
||||
@@ -222,9 +324,13 @@
|
||||
(define (git-clone url [path (default-clone-directory url)] #:quiet [quiet #f])
|
||||
(define label (format "clone ~a" url))
|
||||
(progress-message quiet "[git] ~a" label)
|
||||
(git_clone url
|
||||
(path->string (if (path? path) path (string->path path)))
|
||||
(make-clone-options label quiet))
|
||||
(define-values (options state) (make-clone-options))
|
||||
(call-with-progress
|
||||
label quiet state
|
||||
(lambda ()
|
||||
(git_clone url
|
||||
(path->string (if (path? path) path (string->path path)))
|
||||
options)))
|
||||
(progress-message quiet "[git] ~a: done" label)
|
||||
(git-root path))
|
||||
|
||||
@@ -599,7 +705,10 @@
|
||||
(progress-message quiet "[git] ~a" label)
|
||||
(define repo (open-repository))
|
||||
(define remote (git_remote_lookup repo name))
|
||||
(git_remote_fetch remote #f (make-fetch-options label quiet) label)
|
||||
(define-values (options state) (make-fetch-options))
|
||||
(call-with-progress
|
||||
label quiet state
|
||||
(lambda () (git_remote_fetch/blocking remote #f options label)))
|
||||
(progress-message quiet "[git] ~a: done" label)
|
||||
(void))
|
||||
|
||||
@@ -654,7 +763,7 @@
|
||||
url))
|
||||
(progress-message quiet "[git] ~a" label)
|
||||
(define repo (open-repository))
|
||||
(define options (make-push-options label quiet))
|
||||
(define-values (options state) (make-push-options))
|
||||
;; The public Racket binding for git_remote_push cannot currently marshal a
|
||||
;; non-null git_strarray correctly. Its null form is public and supported:
|
||||
;; libgit2 then uses the remote's configured push refspecs. Use a temporary
|
||||
@@ -669,7 +778,11 @@
|
||||
refspec))
|
||||
(lambda ()
|
||||
(define remote (git_remote_lookup repo temp-name))
|
||||
(git_remote_push remote #f options))
|
||||
(call-with-progress
|
||||
label quiet state
|
||||
(lambda () (git_remote_push/blocking remote #f options))
|
||||
#:bytes? #f
|
||||
#:phase? #t))
|
||||
(lambda ()
|
||||
(define config (git_repository_config repo))
|
||||
(for ([suffix (in-list '("url" "fetch" "push"))])
|
||||
|
||||
Reference in New Issue
Block a user