hans/git-cli
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

better handling for reporting on callbacks from c library

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-11 11:08:17 +02:00
parent baf0ef5868
commit 8027ad2c9c
4 changed files with 164 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README.md
+3
View File
@@ -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)
main.rkt
+156 -43
View File
@@ -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"))])
scribblings/git.scrbl
+2 -2
View File
@@ -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.
tests/remote.rkt
+3 -3
View File
@@ -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))