From 8027ad2c9cceb6bb198c0444aaa793581c550694 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Tue, 11 Aug 2026 11:08:17 +0200 Subject: [PATCH] better handling for reporting on callbacks from c library --- README.md | 3 + main.rkt | 199 +++++++++++++++++++++++++++++++++--------- scribblings/git.scrbl | 4 +- tests/remote.rkt | 6 +- 4 files changed, 164 insertions(+), 48 deletions(-) diff --git a/README.md b/README.md index 8badb32..682d06f 100644 --- a/README.md +++ b/README.md @@ -79,6 +79,9 @@ operations use them automatically: (git 'fetch) (git 'pull) (git 'push) +;; Example while a real push is in progress: +;; [git] push origin/main: compressing 45% (37/82 objects) +;; [git] push origin/main: sending 58% (48/82 objects) ;; Suppress network progress when desired: (git 'push #:quiet #t) diff --git a/main.rkt b/main.rkt index bc692ea..7d60a8c 100644 --- a/main.rkt +++ b/main.rkt @@ -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"))]) diff --git a/scribblings/git.scrbl b/scribblings/git.scrbl index e42a670..bf07e0a 100644 --- a/scribblings/git.scrbl +++ b/scribblings/git.scrbl @@ -109,9 +109,9 @@ Calls @racket[git], displays its result in a compact human-readable form, and re @defproc[(git-pull [remote string? "origin"] [#:quiet quiet any/c #f]) (or/c string? #f)]{Fetches and performs a fast-forward-only update of the current branch. Returns the new OID, or @racket[#f] when already up to date. A non-fast-forward update raises an exception.} -@defproc[(git-push [remote string? "origin"] [branch (or/c string? #f) #f] [#:quiet quiet any/c #f]) void?]{Pushes a branch to a branch with the same name. With no positional arguments, the current branch is pushed to @tt{origin}; with only @racket[remote], the current branch is pushed there. A start and completion message are written to the current output port unless @racket[quiet] is true. Transfer-percentage output is temporarily disabled so that no output is performed from the libgit2 push-progress callback.} +@defproc[(git-push [remote string? "origin"] [branch (or/c string? #f) #f] [#:quiet quiet any/c #f]) void?]{Pushes a branch to a branch with the same name. With no positional arguments, the current branch is pushed to @tt{origin}; with only @racket[remote], the current branch is pushed there. A start and completion message and transfer progress are written to the current output port unless @racket[quiet] is true. Progress callbacks only record transfer state; the libgit2 operation runs in a parallel Racket thread while the calling Racket thread performs output outside FFI callback context. Push progress distinguishes packing/compression from sending when libgit2 reports those phases.} -@defproc[(git-push-tag [tag string?] [remote string? "origin"] [#:quiet quiet any/c #f]) void?]{Pushes one tag. A start and completion message are written to the current output port unless @racket[quiet] is true. Transfer-percentage output is temporarily disabled so that no output is performed from the libgit2 push-progress callback.} +@defproc[(git-push-tag [tag string?] [remote string? "origin"] [#:quiet quiet any/c #f]) void?]{Pushes one tag. A start and completion message and transfer progress are written to the current output port unless @racket[quiet] is true. Progress callbacks only record transfer state; the libgit2 operation runs in a parallel Racket thread while the calling Racket thread performs output outside FFI callback context. Push progress distinguishes packing/compression from sending when libgit2 reports those phases.} Remote HTTPS operations automatically use credentials from the @tt{racket-git} credential store when an entry exists for the remote host. diff --git a/tests/remote.rkt b/tests/remote.rkt index 85ea495..79a2340 100644 --- a/tests/remote.rkt +++ b/tests/remote.rkt @@ -42,9 +42,9 @@ (define push-text (get-output-string push-out)) (check-true (regexp-match? #rx"\\[git\\] push origin/master" push-text)) (check-true (regexp-match? #rx"\\[git\\] push origin/master: done" push-text)) - ;; Push progress callbacks remain installed, but must not perform output - ;; from FFI callback context. Percentage output would indicate a regression. - (check-false (regexp-match? #rx"%" push-text)) + ;; A real push reports transfer progress, but the FFI callback itself only + ;; records state. A normal Racket thread performs the output. + (check-true (regexp-match? #rx"100%" push-text)) (define quiet-out (open-output-string)) (parameterize ([current-output-port quiet-out]) (git 'push #:quiet #t))