better handling for reporting on callbacks from c library

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)

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?
+        (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))
+            label percent current total (quotient (+ bytes 1023) 1024))]
+          [else
            (progress-message
             #f
             "[git] ~a: ~a% (~a/~a objects)"
-             label percent current total))))))
+            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 (set-fetch-progress-callback! callbacks state)
-  (define report (make-progress-reporter label quiet))
   (set-git_remote_callbacks-transfer_progress!
    callbacks
    (lambda (stats _payload)
-     (report (transfer-progress-received-objects 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)
+(define (set-push-progress-callback! callbacks state)
-  ;; Diagnostic 0.2.7a: keep the libgit2 push progress callback installed,
+  (set-git_remote_callbacks-pack_progress!
-  ;; but do no Racket I/O (or other synchronization) from callback context.
+   callbacks
-  ;; Racket CS runs FFI callbacks in atomic mode; writing to DrRacket's output
+   (lambda (stage current total _payload)
-  ;; port from here can therefore crash the process during a real push.
+     ;; 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)
+  (set-fetch-progress-callback! callbacks state)
-  options)
+  (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)
+  (set-push-progress-callback! callbacks state)
-  options)
+  (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)
+  (set-fetch-progress-callback! callbacks state)
-  options)
+  (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)
+  (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)))
-             (make-clone-options label quiet))
+                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

@@ -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

@@ -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
+      ;; A real push reports transfer progress, but the FFI callback itself only
-      ;; from FFI callback context. Percentage output would indicate a regression.
+      ;; records state.  A normal Racket thread performs the output.
-      (check-false (regexp-match? #rx"%" push-text))
+      (check-true (regexp-match? #rx"100%" push-text))
       (define quiet-out (open-output-string))
       (parameterize ([current-output-port quiet-out])
         (git 'push #:quiet #t))