better progress information for git commands

main.rkt

@@ -64,6 +64,7 @@
 (define GIT-CREDTYPE-USERPASS-PLAINTEXT #x0001)
 (define GIT-CREDTYPE-USERNAME #x0020)
 (define GIT-PASSTHROUGH -30)
+(define GIT-CHECKOUT-OPTIONS-VERSION 1)
 
 (define (git-credential-callback out url username-from-url allowed-types _payload)
   ;; Never let a Racket exception escape through a C callback.  In particular,
@@ -96,26 +97,88 @@
   (set-git_remote_callbacks-credentials! callbacks git-credential-callback)
   callbacks)
 
-(define (make-fetch-options)
+(define (progress-message quiet format-string . args)
+  (unless quiet
+    (apply fprintf (current-output-port) format-string args)
+    (newline)
+    (flush-output)))
+
+(define (make-progress-reporter label quiet #:bytes? [bytes? #t])
+  (define last-percent -10)
+  (lambda (current total bytes)
+    (unless (or quiet (zero? total))
+      (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 (transfer-progress-total-objects stats)
+  (ptr-ref stats _uint 0))
+
+(define (transfer-progress-received-objects stats)
+  (ptr-ref stats _uint 2))
+
+(define (transfer-progress-received-bytes stats)
+  ;; 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))
+  (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))
+     0))
+  callbacks)
+
+(define (set-push-progress-callback! callbacks label quiet)
+  (define report (make-progress-reporter label quiet #:bytes? #f))
+  (set-git_remote_callbacks-push_transfer_progress!
+   callbacks
+   (lambda (current total bytes _payload)
+     (report current total bytes)
+     0))
+  callbacks)
+
+(define (make-fetch-options label quiet)
   (define options
     (cast (malloc _git_fetch_opts 'atomic) _pointer _git_fetch_opts-pointer))
   (git_fetch_options_init options GIT_FETCH_OPTS_VERSION)
-  (set-credential-callback! (git_fetch_opts-callbacks options))
+  (define callbacks (git_fetch_opts-callbacks options))
+  (set-credential-callback! callbacks)
+  (set-fetch-progress-callback! callbacks label quiet)
   options)
 
-(define (make-push-options)
+(define (make-push-options label quiet)
   (define options
     (cast (malloc _git_push_opts 'atomic) _pointer _git_push_opts-pointer))
   (git_push_options_init options GIT_PUSH_OPTS_VERSION)
-  (set-credential-callback! (git_push_opts-callbacks options))
+  (define callbacks (git_push_opts-callbacks options))
+  (set-credential-callback! callbacks)
+  (set-push-progress-callback! callbacks label quiet)
   options)
 
-(define (make-clone-options)
+(define (make-clone-options label quiet)
   (define options
     (cast (malloc _git_clone_opts 'atomic) _pointer _git_clone_opts-pointer))
   (git_clone_options_init options GIT_CLONE_OPTS_VERSION)
-  (set-credential-callback!
-   (git_fetch_opts-callbacks (git_clone_opts-fetch_opts options)))
+  (define callbacks
+    (git_fetch_opts-callbacks (git_clone_opts-fetch_opts options)))
+  (set-credential-callback! callbacks)
+  (set-fetch-progress-callback! callbacks label quiet)
   options)
 
 (define (blank-oid)
@@ -152,15 +215,14 @@
     (error 'git-clone "cannot derive a directory name from ~a" url))
   (regexp-replace #rx"[.]git$" (last parts) ""))
 
-(define git-clone
-  (case-lambda
-    [(url)
-     (git-clone url (default-clone-directory url))]
-    [(url path)
-     (git_clone url
-                (path->string (if (path? path) path (string->path path)))
-                (make-clone-options))
-     (git-root path)]))
+(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))
+  (progress-message quiet "[git] ~a: done" label)
+  (git-root path))
 
 (define (normalize-status-flags flags)
   (cond
@@ -397,19 +459,29 @@
   (git_branch_delete ref)
   (void))
 
+(define (make-safe-checkout-options)
+  ;; A null checkout-options pointer means GIT_CHECKOUT_NONE (dry run).
+  ;; Initialize the options explicitly so checkout actually updates the index
+  ;; and worktree while preserving local modifications.
+  (define options
+    (cast (malloc _git_checkout_opts 'atomic) _pointer _git_checkout_opts-pointer))
+  (git_checkout_options_init options GIT-CHECKOUT-OPTIONS-VERSION)
+  options)
+
 (define (git-checkout name)
   (define repo (open-repository))
+  (define options (make-safe-checkout-options))
   (cond
     [(member name (git-branches))
      (define refname (string-append branch-prefix name))
      (define object (git_revparse_single repo (string-append refname "^{commit}")))
      ;; Checkout first: with default safe checkout, a dirty worktree aborts
      ;; before HEAD is changed.
-     (git_checkout_tree repo object #f)
+     (git_checkout_tree repo object options)
      (git_repository_set_head repo refname)]
     [else
      (define object (git_revparse_single repo (string-append name "^{commit}")))
-     (git_checkout_tree repo object #f)
+     (git_checkout_tree repo object options)
      (git_repository_set_head_detached repo (git_object_id object))])
   (git-head))
 
@@ -518,19 +590,26 @@
            remote-name))
   url)
 
-(define (git-fetch [name "origin"])
+(define (fetch-remote name quiet label)
   (check-remote-credentials 'git-fetch name)
+  (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) (format "fetch ~a" name))
+  (git_remote_fetch remote #f (make-fetch-options label quiet) label)
+  (progress-message quiet "[git] ~a: done" label)
   (void))
 
-(define (git-pull [remote-name "origin"])
+(define (git-fetch [name "origin"] #:quiet [quiet #f])
+  (fetch-remote name quiet (format "fetch ~a" name)))
+
+(define (git-pull [remote-name "origin"] #:quiet [quiet #f])
   (define branch (git-current-branch))
   (unless branch
     (error 'git-pull "pull requires an attached local branch"))
 
-  (git-fetch remote-name)
+  (define label (format "pull ~a/~a" remote-name branch))
+  (progress-message quiet "[git] ~a" label)
+  (fetch-remote remote-name quiet (format "fetch ~a" remote-name))
 
   (define repo (open-repository))
   (define local-ref-name (string-append branch-prefix branch))
@@ -542,13 +621,17 @@
   (define remote-id (git_object_id remote-object))
 
   (cond
-    [(git_oid_equal local-id remote-id) #f]
+    [(git_oid_equal local-id remote-id)
+     (progress-message quiet "[git] ~a: already up to date" label)
+     #f]
     [(git_graph_descendant_of repo remote-id local-id)
      ;; Update the worktree safely before moving the branch reference.
-     (git_checkout_tree repo remote-object #f)
+     (git_checkout_tree repo remote-object (make-safe-checkout-options))
      (git_reference_set_target
       local-ref remote-id (format "pull: fast-forward from ~a" remote-name))
-     (git_oid_fmt remote-id)]
+     (define oid (git_oid_fmt remote-id))
+     (progress-message quiet "[git] ~a: fast-forwarded" label)
+     oid]
     [else
      (error 'git-pull
             "non-fast-forward pull is not supported; merge or rebase explicitly")]))
@@ -558,15 +641,16 @@
           (inexact->exact (floor (current-inexact-milliseconds)))
           (random 1000000000)))
 
-(define (push-refspec remote-name refspec)
+(define (push-refspec remote-name refspec quiet label)
   (define url (check-remote-credentials 'git-push remote-name))
   (when (and (http-remote? url)
              (not (git-credentials-configured? url)))
     (error 'git-push
            "no HTTPS credentials are stored for ~a; use (git 'credentials 'set <url> <username> <token>)"
            url))
+  (progress-message quiet "[git] ~a" label)
   (define repo (open-repository))
-  (define options (make-push-options))
+  (define options (make-push-options label quiet))
   ;; 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
@@ -589,39 +673,32 @@
           (git_config_delete_entry
            config
            (format "remote.~a.~a" temp-name suffix))))))
+  (progress-message quiet "[git] ~a: done" label)
   (void))
 
-(define git-push
-  (case-lambda
-    [()
-     (define branch (git-current-branch))
-     (unless branch
-       (error 'git-push "push requires an attached local branch"))
-     (git-push "origin" branch)]
-    [(remote-name)
-     (define branch (git-current-branch))
-     (unless branch
-       (error 'git-push "push requires an attached local branch"))
-     (git-push remote-name branch)]
-    [(remote-name branch)
-     (push-refspec
-      remote-name
-      (format "refs/heads/~a:refs/heads/~a" branch branch))]))
+(define (git-push [remote-name "origin"] [branch #f] #:quiet [quiet #f])
+  (define actual-branch (or branch (git-current-branch)))
+  (unless actual-branch
+    (error 'git-push "push requires an attached local branch"))
+  (push-refspec
+   remote-name
+   (format "refs/heads/~a:refs/heads/~a" actual-branch actual-branch)
+   quiet
+   (format "push ~a/~a" remote-name actual-branch)))
 
-(define git-push-tag
-  (case-lambda
-    [(tag) (git-push-tag tag "origin")]
-    [(tag remote-name)
-     (push-refspec
-      remote-name
-      (format "refs/tags/~a:refs/tags/~a" tag tag))]))
+(define (git-push-tag tag [remote-name "origin"] #:quiet [quiet #f])
+  (push-refspec
+   remote-name
+   (format "refs/tags/~a:refs/tags/~a" tag tag)
+   quiet
+   (format "push tag ~a to ~a" tag remote-name)))
 
-(define (git command . args)
+(define (git command #:quiet [quiet #f] . args)
   (unless (symbol? command)
     (raise-argument-error 'git "symbol?" command))
   (case command
     [(init) (apply git-init args)]
-    [(clone) (apply git-clone args)]
+    [(clone) (keyword-apply git-clone '(#:quiet) (list quiet) args)]
     [(status) (apply git-status args)]
     [(diff) (apply git-diff args)]
     [(add) (apply git-add args)]
@@ -646,10 +723,10 @@
        [(list 'add name url) (git-remote-add name url)]
        [(list 'get-url name) (git-remote-url name)]
        [_ (error 'git "invalid remote arguments: ~e" args)])]
-    [(fetch) (apply git-fetch args)]
-    [(pull) (apply git-pull args)]
-    [(push) (apply git-push args)]
-    [(push-tag) (apply git-push-tag args)]
+    [(fetch) (keyword-apply git-fetch '(#:quiet) (list quiet) args)]
+    [(pull) (keyword-apply git-pull '(#:quiet) (list quiet) args)]
+    [(push) (keyword-apply git-push '(#:quiet) (list quiet) args)]
+    [(push-tag) (keyword-apply git-push-tag '(#:quiet) (list quiet) args)]
     [(credentials)
      (match args
        [(list 'init password) (git-credentials-init! password)]
@@ -706,7 +783,8 @@
     [(void? result) (void)]
     [else (displayln result out)]))
 
-(define (dgit command . args)
-  (define result (apply git command args))
+(define (dgit command #:quiet [quiet #f] . args)
+  (define result
+    (keyword-apply git '(#:quiet) (list quiet) (cons command args)))
   (display-git-result command result)
   result)