#lang racket/base

(require ffi/unsafe
         racket/async-channel
         racket/list
         racket/match
         racket/path
         racket/string
         "credentials.rkt"
         libgit2)

(provide git
         dgit
         git-repository?
         git-root
         git-init
         git-clone
         (struct-out git-status-entry)
         git-status
         git-status-lines
         git-clean?
         git-diff
         git-add
         git-config
         git-config-get
         git-config-set
         git-commit
         git-head
         git-current-branch
         git-branches
         git-branch
         git-branch-delete
         git-checkout
         git-checkout-new
         git-tags
         git-tag
         git-tag-delete
         (struct-out git-log-entry)
         git-log
         git-log-lines
         git-remotes
         git-remote-add
         git-remote-url
         git-fetch
         git-pull
         git-push
         git-push-tag
         git-credentials-init!
         git-credentials-unlock!
         git-credentials-lock!
         git-credentials-unlocked?
         git-credentials-unlock-expires
         git-credentials-set!
         git-credentials-ref
         git-credentials-configured?
         git-credentials-remove!)

(struct git-status-entry (path code flags) #:transparent)
(struct git-log-entry (id summary time) #:transparent)

(define zero-oid-string (make-string GIT_OID_HEXSZ #\0))
(define branch-prefix "refs/heads/")
(define tag-prefix "refs/tags/")

(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,
  ;; a locked credential store used to throw here, which can destabilize the
  ;; enclosing Racket/DrRacket process.
  (with-handlers ([exn:fail? (lambda (_) GIT-PASSTHROUGH)])
    (define saved (git-credentials-ref url))
    (cond
      [(not saved) GIT-PASSTHROUGH]
      [else
       (define username
         (if (and username-from-url (not (string=? username-from-url "")))
             username-from-url
             (car saved)))
       (define token (cdr saved))
       (cond
         [(not (zero? (bitwise-and allowed-types GIT-CREDTYPE-USERPASS-PLAINTEXT)))
          (ptr-set! out _git_credential
                    (git_credential_userpass_plaintext_new username token))
          0]
         [(not (zero? (bitwise-and allowed-types GIT-CREDTYPE-USERNAME)))
          ;; This credential is only used as an intermediate username response.
          ;; libgit2 owns the credential after the callback returns.
          (ptr-set! out _git_credential
                    (git_credential_username_new username))
          0]
         [else GIT-PASSTHROUGH])])))

(define (set-credential-callback! callbacks)
  ;; 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)
  (unless quiet
    (apply fprintf (current-output-port) format-string args)
    (newline)
    (flush-output)))

(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 (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)
        (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))

(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 state)
  (set-git_remote_callbacks-transfer_progress!
   callbacks
   (lambda (stats _payload)
     (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 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)
     (progress-state-set! state 3 current total bytes)
     0))
  callbacks)

(define (make-fetch-options)
  (define state (make-progress-state))
  (define options
    (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 state)
  (values options state))

(define (make-push-options)
  (define state (make-progress-state))
  (define options
    (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 state)
  (values options state))

(define (make-clone-options)
  (define state (make-progress-state))
  (define options
    (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 state)
  (values options state))

(define (blank-oid)
  (git_oid_fromstr zero-oid-string))

(define (repository-path [start (current-directory)])
  (or (git_repository_discover start)
      (error 'git "not inside a Git repository: ~a" start)))

(define (open-repository [start (current-directory)])
  (git_repository_open (repository-path start)))

(define (git-repository? [path (current-directory)])
  (and (git_repository_discover path) #t))

(define (git-root [path (current-directory)])
  (define repo (open-repository path))
  (define root
    (if (git_repository_is_bare repo)
        (git_repository_path repo)
        (git_repository_workdir repo)))
  (simplify-path (string->path root)))

(define (git-init [path (current-directory)] #:bare? [bare? #f])
  (git_repository_init path #:bare? bare?)
  (git-root path))

(define (default-clone-directory url)
  (define cleaned (regexp-replace #rx"/+$" url ""))
  (define parts
    (filter (lambda (s) (not (string=? s "")))
            (regexp-split #rx"[/\\\\:]" cleaned)))
  (unless (pair? parts)
    (error 'git-clone "cannot derive a directory name from ~a" url))
  (regexp-replace #rx"[.]git$" (last parts) ""))

(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)))
                options)))
  (progress-message quiet "[git] ~a: done" label)
  (git-root path))

(define (normalize-status-flags flags)
  (cond
    [(list? flags) flags]
    [(symbol? flags)
     (if (eq? flags 'GIT_STATUS_CURRENT) null (list flags))]
    [else null]))

(define (has-status? flags flag)
  (and (memq flag flags) #t))

(define (index-status-char flags)
  (cond
    [(has-status? flags 'GIT_STATUS_INDEX_NEW) #\A]
    [(has-status? flags 'GIT_STATUS_INDEX_MODIFIED) #\M]
    [(has-status? flags 'GIT_STATUS_INDEX_DELETED) #\D]
    [(has-status? flags 'GIT_STATUS_INDEX_RENAMED) #\R]
    [(has-status? flags 'GIT_STATUS_INDEX_TYPECHANGE) #\T]
    [else #\space]))

(define (worktree-status-char flags)
  (cond
    [(has-status? flags 'GIT_STATUS_WT_MODIFIED) #\M]
    [(has-status? flags 'GIT_STATUS_WT_DELETED) #\D]
    [(has-status? flags 'GIT_STATUS_WT_RENAMED) #\R]
    [(has-status? flags 'GIT_STATUS_WT_TYPECHANGE) #\T]
    [(has-status? flags 'GIT_STATUS_WT_UNREADABLE) #\?]
    [else #\space]))

(define (status-code flags)
  (cond
    [(has-status? flags 'GIT_STATUS_CONFLICTED) "UU"]
    [(has-status? flags 'GIT_STATUS_IGNORED) "!!"]
    [(has-status? flags 'GIT_STATUS_WT_NEW) "??"]
    [else
     (string (index-status-char flags)
             (worktree-status-char flags))]))

(define (git-status)
  (define repo (open-repository))
  (define result null)
  (git_status_foreach
   repo
   (lambda (path raw-flags _payload)
     (define flags (normalize-status-flags raw-flags))
     ;; Match normal `git status`: ignored files are not shown unless
     ;; explicitly requested.  git_status_foreach uses libgit2's defaults,
     ;; which may include them.
     (unless (has-status? flags 'GIT_STATUS_IGNORED)
       (set! result
             (cons (git-status-entry path (status-code flags) flags)
                   result)))
     0)
   #"")
  (sort result
        (lambda (a b)
          (string<? (git-status-entry-path a)
                    (git-status-entry-path b)))))

(define (git-status-lines [entries (git-status)])
  (for/list ([entry (in-list entries)])
    (format "~a ~a"
            (git-status-entry-code entry)
            (git-status-entry-path entry))))

(define (git-clean?)
  (null? (git-status)))

(define (make-diff-options)
  (define options
    (cast (malloc _git_diff_opts 'atomic) _pointer _git_diff_opts-pointer))
  (git_diff_options_init options GIT_DIFF_OPTS_VERSION)
  options)

(define (diff->string diff)
  (define bs (git_diff_to_buf diff 'GIT_DIFF_FORMAT_PATCH))
  (if bs (bytes->string/utf-8 bs #\uFFFD) ""))

(define (git-diff . args)
  (define repo (open-repository))
  (define options (make-diff-options))
  (define index (git_repository_index repo))
  (define diff
    (match args
      ['()
       ;; Same basic comparison as `git diff`: index versus worktree.
       (git_diff_index_to_workdir repo index options)]
      [(list '--cached)
       ;; Same basic comparison as `git diff --cached`: HEAD tree versus index.
       (define parent (head-commit repo))
       (unless parent
         (error 'git-diff "--cached requires an existing HEAD commit"))
       (define tree (git_commit_tree parent))
       (git_diff_tree_to_index repo tree index options)]
      [_ (error 'git-diff "invalid arguments: ~e" args)]))
  (diff->string diff))

(define (git-path-string path)
  (regexp-replace* #rx"\\\\" (path->string path) "/"))

(define (relative-pathspec workdir path)
  (define p0 (if (path? path) path (string->path path)))
  ;; A relative path supplied by the caller is relative to the caller's
  ;; current directory, not automatically to the repository root.
  (define p (path->complete-path p0 (current-directory)))
  (define rel (find-relative-path workdir p))
  (define s (git-path-string rel))
  (when (or (string=? s "..")
            (string-prefix? s "../"))
    (error 'git-add "path is outside the repository: ~a" path))
  s)

(define (index-accept _path _matched-pathspec _payload)
  0)

(define (git-add . paths)
  (define repo (open-repository))
  (define workdir (string->path (git_repository_workdir repo)))
  (define index (git_repository_index repo))
  (define pathspecs
    (make-git_strarray
     (for/list ([path (in-list paths)])
       (relative-pathspec workdir path))))
  ;; update-all stages changes and removals of already tracked files;
  ;; add-all adds new files and updates existing files while respecting ignores.
  (git_index_update_all index pathspecs index-accept #"")
  (git_index_add_all index pathspecs 'GIT_INDEX_ADD_DEFAULT index-accept #"")
  (git_index_write index)
  (void))

(define (git-config-get key)
  (define repo (open-repository))
  (define config (git_repository_config repo))
  ;; git_config_get_string is incorrectly declared as an allocating wrapper
  ;; in the current Racket libgit2 package.  The entry API has the correct
  ;; ownership model and works on normal repository config objects.
  (define entry (git_config_get_entry config key))
  (git_config_entry-value entry))

(define (git-config-set key value)
  (define repo (open-repository))
  (define config (git_repository_config repo))
  (git_config_set_string config key value)
  value)

(define git-config
  (case-lambda
    [(key) (git-config-get key)]
    [(key value) (git-config-set key value)]))

(define (head-commit repo)
  (cond
    [(git_repository_is_empty repo) #f]
    [(git_repository_head_unborn repo) #f]
    [else
     (define head (git_repository_head repo))
     (git_commit_lookup repo (git_reference_target head))]))

(define (git-head)
  (define repo (open-repository))
  (define commit (head-commit repo))
  (and commit (git_oid_fmt (git_commit_id commit))))

(define (git-commit message)
  (define repo (open-repository))
  (define index (git_repository_index repo))
  (when (git_index_has_conflicts index)
    (error 'git-commit "the index contains unresolved conflicts"))

  (define tree-id (blank-oid))
  (git_index_write_tree tree-id index)
  (define tree (git_tree_lookup repo tree-id))
  (define parent (head-commit repo))

  (cond
    [(and (not parent) (zero? (git_index_entrycount index)))
     (error 'git-commit "nothing staged to commit")]
    [(and parent (git_oid_equal tree-id (git_commit_tree_id parent)))
     (error 'git-commit "nothing staged to commit")])

  (define signature (git_signature_default repo))
  (define commit-id (blank-oid))
  (if parent
      (git_commit_create_v commit-id repo "HEAD"
                           signature signature #f message tree
                           1 parent)
      (git_commit_create_v commit-id repo "HEAD"
                           signature signature #f message tree
                           0))
  (git_oid_fmt commit-id))

(define (git-current-branch)
  (define repo (open-repository))
  (cond
    [(git_repository_head_detached repo) #f]
    [(git_repository_head_unborn repo)
     (define head (git_reference_lookup repo "HEAD"))
     (define target (git_reference_symbolic_target head))
     (and target
          (string-prefix? target branch-prefix)
          (substring target (string-length branch-prefix)))]
    [else
     (git_reference_shorthand (git_repository_head repo))]))

(define (git-branches)
  (define repo (open-repository))
  (define branches null)
  (git_reference_foreach_name
   repo
   (lambda (name _payload)
     (when (string-prefix? name branch-prefix)
       (set! branches
             (cons (substring name (string-length branch-prefix)) branches)))
     0)
   #"")
  (sort branches string<?))

(define (create-branch name)
  (define repo (open-repository))
  (define commit (head-commit repo))
  (unless commit
    (error 'git-branch "cannot create a branch before the first commit"))
  (git_branch_create repo name commit #f)
  name)

(define git-branch
  (case-lambda
    [() (git-branches)]
    [(name) (create-branch name)]))

(define (git-branch-delete name)
  (define repo (open-repository))
  (define ref (git_branch_lookup repo name 'GIT_BRANCH_LOCAL))
  (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 options)
     (git_repository_set_head repo refname)]
    [else
     (define object (git_revparse_single repo (string-append name "^{commit}")))
     (git_checkout_tree repo object options)
     (git_repository_set_head_detached repo (git_object_id object))])
  (git-head))

(define (git-checkout-new name)
  (git-branch name)
  (git-checkout name))

(define (git-tags)
  (define tags null)
  (git_tag_foreach
   (open-repository)
   (lambda (name _oid _payload)
     (set! tags
           (cons (if (string-prefix? name tag-prefix)
                     (substring name (string-length tag-prefix))
                     name)
                 tags))
     0)
   #"")
  (sort tags string<?))

(define (create-tag name)
  (define repo (open-repository))
  (unless (head-commit repo)
    (error 'git-tag "cannot tag a repository without commits"))
  (define target (git_revparse_single repo "HEAD^{commit}"))
  (define tag-id (blank-oid))
  (git_tag_create_lightweight tag-id repo name target #f)
  (git_oid_fmt tag-id))

(define git-tag
  (case-lambda
    [() (git-tags)]
    [(name) (create-tag name)]))

(define (git-tag-delete name)
  (git_tag_delete (open-repository) name)
  (void))

(define (git-log [max-count 20])
  (unless (exact-nonnegative-integer? max-count)
    (raise-argument-error 'git-log "exact-nonnegative-integer?" max-count))
  (define repo (open-repository))
  (cond
    [(not (head-commit repo)) null]
    [else
     (define walk (git_revwalk_new repo))
     (git_revwalk_sorting walk '(GIT_SORT_TOPOLOGICAL GIT_SORT_TIME))
     (git_revwalk_push_head walk)
     (let loop ([left max-count] [result null])
       (cond
         [(zero? left) (reverse result)]
         [else
          (define oid (git_revwalk_next walk))
          (if oid
              (let ([commit (git_commit_lookup repo oid)])
                (loop (sub1 left)
                      (cons (git-log-entry (git_oid_fmt oid)
                                           (or (git_commit_summary commit) "")
                                           (git_commit_time commit))
                            result)))
              (reverse result))]))]))

(define (git-log-lines [entries (git-log)])
  (for/list ([entry (in-list entries)])
    (format "~a ~a"
            (substring (git-log-entry-id entry) 0 7)
            (git-log-entry-summary entry))))

(define (git-remotes)
  ;; git_remote_list is affected by the same git_strarray wrapper problem as
  ;; git_tag_list in the current Racket bindings.  Remote URLs are stored in
  ;; repository config, so enumerate those entries instead.
  (define repo (open-repository))
  (define config (git_repository_config repo))
  (define remotes null)
  (git_config_foreach
   config
   (lambda (entry _payload)
     (define key (git_config_entry-name entry))
     (define m (regexp-match #rx"^remote[.](.+)[.]url$" key))
     (when m
       (set! remotes (cons (cadr m) remotes)))
     0)
   #"")
  (sort (remove-duplicates remotes) string<?))

(define (git-remote-add name url)
  (git_remote_create (open-repository) name url)
  name)

(define (git-remote-url [name "origin"])
  (define remote (git_remote_lookup (open-repository) name))
  (git_remote_url remote))

(define (http-remote? url)
  (and (string? url) (regexp-match? #px"^https?://" url)))

(define (check-remote-credentials who remote-name)
  (define url (git-remote-url remote-name))
  (when (and (http-remote? url)
             (git-credentials-configured? url)
             (not (git-credentials-unlocked?)))
    (error who
           "credential store 'racket-git is locked for remote ~a; use (git 'credentials 'unlock <password>)"
           remote-name))
  url)

(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))
  (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))

(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"))

  (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))
  (define local-ref (git_reference_lookup repo local-ref-name))
  (define local-id (git_reference_target local-ref))
  (define remote-spec
    (format "refs/remotes/~a/~a^{commit}" remote-name branch))
  (define remote-object (git_revparse_single repo remote-spec))
  (define remote-id (git_object_id remote-object))

  (cond
    [(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 (make-safe-checkout-options))
     (git_reference_set_target
      local-ref remote-id (format "pull: fast-forward from ~a" remote-name))
     (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")]))

(define (temporary-remote-name)
  (format "racket-git-push-~a-~a"
          (inexact->exact (floor (current-inexact-milliseconds)))
          (random 1000000000)))

(define (remove-temporary-remote-refs! repo temp-name)
  (define prefix (format "refs/remotes/~a/" temp-name))
  (for ([ref-name (in-list (git_reference_list repo))]
        #:when (string-prefix? ref-name prefix))
    (git_reference_remove repo ref-name)))

(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-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
  ;; remote so the user's real remote configuration is never modified.
  (define temp-name (temporary-remote-name))
  (dynamic-wind
    (lambda ()
      (git_remote_create repo temp-name url)
      (define config (git_repository_config repo))
      (git_config_set_string config
                             (format "remote.~a.push" temp-name)
                             refspec))
    (lambda ()
      (define remote (git_remote_lookup repo temp-name))
      (call-with-progress
       label quiet state
       (lambda () (git_remote_push/blocking remote #f options))
       #:bytes? #f
       #:phase? #t))
    (lambda ()
      ;; git_remote_create installs a fetch refspec for the temporary remote.
      ;; A successful push can therefore leave a remote-tracking ref such as
      ;; refs/remotes/racket-git-push-.../main behind.  Remove all refs owned
      ;; by the temporary remote before deleting its configuration.
      (with-handlers ([exn:fail? void])
        (remove-temporary-remote-refs! repo temp-name))
      (define config (git_repository_config repo))
      (for ([suffix (in-list '("url" "fetch" "push"))])
        (with-handlers ([exn:fail? void])
          (git_config_delete_entry
           config
           (format "remote.~a.~a" temp-name suffix))))))
  (progress-message quiet "[git] ~a: done" label)
  (void))

(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 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 #:quiet [quiet #f] . args)
  (unless (symbol? command)
    (raise-argument-error 'git "symbol?" command))
  (case command
    [(init) (apply git-init 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)]
    [(config) (apply git-config args)]
    [(commit) (apply git-commit args)]
    [(branch)
     (match args
       [(list '-d name) (git-branch-delete name)]
       [_ (apply git-branch args)])]
    [(checkout)
     (match args
       [(list '-b name) (git-checkout-new name)]
       [_ (apply git-checkout args)])]
    [(tag)
     (match args
       [(list '-d name) (git-tag-delete name)]
       [_ (apply git-tag args)])]
    [(log) (apply git-log args)]
    [(remote)
     (match args
       ['() (git-remotes)]
       [(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) (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)]
       [(list 'unlock password) (git-credentials-unlock! password)]
       [(list 'unlock password seconds)
        (git-credentials-unlock! password #:for seconds)]
       [(list 'lock) (git-credentials-lock!)]
       [(list 'unlocked?) (git-credentials-unlocked?)]
       [(list 'set remote username token)
        (git-credentials-set! remote username token)]
       [(list 'configured? remote) (git-credentials-configured? remote)]
       [(list 'remove remote) (git-credentials-remove! remote)]
       [_ (error 'git "invalid credentials arguments: ~e" args)])]
    [else (error 'git "unknown command: ~a" command)]))

(define (status-description entry)
  (define flags (git-status-entry-flags entry))
  (cond
    [(has-status? flags 'GIT_STATUS_CONFLICTED) "Conflicted"]
    [(has-status? flags 'GIT_STATUS_WT_NEW) "New"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_RENAMED)
         (has-status? flags 'GIT_STATUS_WT_RENAMED)) "Renamed"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_DELETED)
         (has-status? flags 'GIT_STATUS_WT_DELETED)) "Deleted"]
    [(has-status? flags 'GIT_STATUS_INDEX_NEW) "Added"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_TYPECHANGE)
         (has-status? flags 'GIT_STATUS_WT_TYPECHANGE)) "Type changed"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_MODIFIED)
         (has-status? flags 'GIT_STATUS_WT_MODIFIED)) "Modified"]
    [(has-status? flags 'GIT_STATUS_WT_UNREADABLE) "Unreadable"]
    [else (git-status-entry-code entry)]))

(define (pad-right value width)
  (define text (format "~a" value))
  (string-append text (make-string (max 0 (- width (string-length text))) #\space)))

(define (display-git-result command result [out (current-output-port)])
  (cond
    [(eq? command 'status)
     (for ([entry (in-list result)])
       (fprintf out "~a - ~a\n"
                (pad-right (status-description entry) 12)
                (git-status-entry-path entry)))]
    [(eq? command 'diff)
     (display result out)]
    [(eq? command 'log)
     (for ([entry (in-list result)])
       (fprintf out "~a ~a\n"
                (substring (git-log-entry-id entry) 0 7)
                (git-log-entry-summary entry)))]
    [(list? result)
     (for ([item (in-list result)])
       (displayln item out))]
    [(void? result) (void)]
    [else (displayln result out)]))

(define (dgit command #:quiet [quiet #f] . args)
  (define result
    (keyword-apply git '(#:quiet) (list quiet) (cons command args)))
  (display-git-result command result)
  result)