Safe callback mechanism to give dependent packages a normal racket environment.

Author: hdijkema

Makefile.rkt

@@ -0,0 +1,21 @@
+#lang racket
+
+(require racket-makefile
+         package-zipper
+         )
+
+
+(target all
+        (displayln "use (make clean) or (make package)")
+        )
+
+(target clean
+        (for-each (λ (f) (displayln f) (rm-f f)) (list-files "libgit2" #px"([.]bak|~)$" #:recursive #t))
+        (for-each (λ (d) (displayln d) (rm-rf d)) (list-dirs "libgit2" #px"(compiled|doc)$" #:recursive #t))
+        (for-each (λ (f) (displayln f) (rm-f f)) (list-files "libgit2/scribblings" #px"[.](css|js|html)$"))
+        )
+
+(target package
+        (deps clean)
+        (zip-package))
+                 

libgit2/include/remote.rkt

@@ -1,6 +1,7 @@
 #lang racket
 
 (require ffi/unsafe
+         ffi/unsafe/os-async-channel
          (only-in "net.rkt"
                   _git_direction
                   _git_remote_head)
@@ -29,6 +30,24 @@
            GIT_REMOTE_COMPLETION_INDEXING
            GIT_REMOTE_COMPLETION_ERROR)))
 
+;; Blocking remote callouts allow other Racket threads to run while libgit2 is
+;; doing network/pack work.  Racket requires callbacks entered from such a
+;; callout to have a non-#f #:async-apply.  Queue callback thunks to an ordinary
+;; Racket thread so callback bodies may safely perform normal Racket work.
+(define remote-callback-channel (make-os-async-channel))
+
+(define remote-callback-dispatch-thread
+  (thread
+   (lambda ()
+     (let loop ()
+       (define thunk (sync remote-callback-channel))
+       (thunk)
+       (loop)))))
+
+(define (remote-callback-async-apply thunk)
+  ;; os-async-channel-put is valid in atomic mode and from an OS thread.
+  (os-async-channel-put remote-callback-channel thunk))
+
 ;; libgit2 can retain all callbacks in this structure for the lifetime of a
 ;; remote transport. Use an explicit #:keep hook so the generated callback
 ;; values can be tied to the git_remote lifetime instead of only to the
@@ -43,6 +62,7 @@
 
 (define _git_remote_credential_acquire_cb
   (_fun #:keep keep-current-callback!
+        #:async-apply remote-callback-async-apply
         (_cpointer _git_credential) _string _string _uint _pointer -> _int))
 
 (define _git_remote_certificate_check_cb
@@ -51,6 +71,7 @@
 
 (define _git_remote_transfer_progress_cb
   (_fun #:keep keep-current-callback!
+        #:async-apply remote-callback-async-apply
         _git_transfer_progress-pointer _pointer -> _int))
 
 (define _git_remote_update_tips_cb
@@ -59,10 +80,12 @@
 
 (define _git_remote_pack_progress_cb
   (_fun #:keep keep-current-callback!
+        #:async-apply remote-callback-async-apply
         _int _uint32 _uint32 _pointer -> _int))
 
 (define _git_push_transfer_progress
   (_fun #:keep keep-current-callback!
+        #:async-apply remote-callback-async-apply
         _uint _uint _size _pointer -> _int))
 
 (define-cstruct _git_push_update
@@ -395,6 +418,18 @@
         _string
         -> _int))
 
+;; Blocking variant for callers that need other Racket threads to remain
+;; schedulable while libgit2 fetches.  Callbacks used with this variant must
+;; have a non-#f #:async-apply.
+(define-libgit2 git_remote_fetch/blocking
+  (_fun #:blocking? #t
+        _git_remote
+        (_or-null _git_strarray-pointer)
+        _git_fetch_opts-pointer/null
+        _string
+        -> (_git_error_code/check))
+  #:c-id git_remote_fetch)
+
 (define-libgit2 git_remote_get_fetch_refspecs
   (_fun [lst : (_git_strarray-pointer/alloc)]
         _git_remote
@@ -454,6 +489,15 @@
         _git_push_opts-pointer/null
         -> _int))
 
+;; Blocking variant; see git_remote_fetch/blocking.
+(define-libgit2 git_remote_push/blocking
+  (_fun #:blocking? #t
+        _git_remote
+        (_or-null _git_strarray-pointer)
+        _git_push_opts-pointer/null
+        -> (_git_error_code/check))
+  #:c-id git_remote_push)
+
 (define-libgit2 git_remote_pushurl
   (_fun _git_remote -> _string))
 
@@ -529,6 +573,12 @@
           (retain-owner-callbacks-for-remote! remote opts)
           (raw remote refspecs opts reflog-message))))
 
+(let ([raw git_remote_fetch/blocking])
+  (set! git_remote_fetch/blocking
+        (lambda (remote refspecs opts reflog-message)
+          (retain-owner-callbacks-for-remote! remote opts)
+          (raw remote refspecs opts reflog-message))))
+
 (let ([raw git_remote_prune])
   (set! git_remote_prune
         (lambda (remote callbacks)
@@ -541,6 +591,12 @@
           (retain-owner-callbacks-for-remote! remote opts)
           (raw remote refspecs opts))))
 
+(let ([raw git_remote_push/blocking])
+  (set! git_remote_push/blocking
+        (lambda (remote refspecs opts)
+          (retain-owner-callbacks-for-remote! remote opts)
+          (raw remote refspecs opts))))
+
 (let ([raw git_remote_update_tips])
   (set! git_remote_update_tips
         (lambda (remote callbacks update-fetchhead download-tags reflog-message)

libgit2/test/test-remote-signatures.rkt

@@ -46,6 +46,18 @@
        (lambda ()
          (git_remote_fetch remote #f #f #f)))
 
+      ;; Blocking variants use the same C entry points but allow a caller to
+      ;; execute them in a parallel Racket thread while callbacks are safely
+      ;; dispatched through #:async-apply.
+      (check-exn
+       exn:fail?
+       (lambda ()
+         (git_remote_fetch/blocking remote #f #f #f)))
+      (check-exn
+       exn:fail?
+       (lambda ()
+         (git_remote_push/blocking remote #f #f)))
+
       ;; Fetch refspec output is owned by the caller and must be consumed just
       ;; like the push-refspec output.
       (check-equal?