#lang racket/base

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

(provide git
         dgit
         git-version
         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-restore
         git-reset
         git-config
         git-config-get
         git-config-set
         git-commit
         git-head
         git-current-branch
         git-switch
         git-branches
         git-branch-create
         git-branch
         git-branch-delete
         git-checkout
         git-checkout-new
         git-merge
         git-tags
         git-tag
         git-tag-delete
         (struct-out git-log-entry)
         (struct-out git-grep-entry)
         git-grep
         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!
         git-prompt
         )

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

(define-runtime-path git-command-directory ".")

(define (git-version)
  (define info (get-info/full git-command-directory))
  (unless info
    (error 'git-version "cannot read info.rkt"))
  (info 'version (lambda () (error 'git-version "info.rkt has no version"))))

(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-MERGE-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 (git-prompt . msg)
  (let ((m (if (null? msg)
               (begin
                 (display "Give (commit) message: ")
                 (flush-output)
                 (let ((line (read-line)))
                   line))
               (car msg))))
    m))

(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 [who 'git-add])
  (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 who "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 (revision-string revision)
  (cond
    [(symbol? revision) (symbol->string revision)]
    [(string? revision) revision]
    [else
     (raise-argument-error 'git "(or/c symbol? string?)" revision)]))

(define (resolve-reset-target repo revision [allow-unborn-head? #f])
  (define revision-name (revision-string revision))
  (cond
    [(and allow-unborn-head?
          (string=? revision-name "HEAD")
          (not (head-commit repo)))
     #f]
    [else
     (with-handlers ([exn:fail?
                      (lambda (_)
                        (error 'git-reset "cannot resolve revision: ~a" revision-name))])
       (git_revparse_single repo (format "~a^{commit}" revision-name)))]))

(define (make-pathspecs repo paths who)
  (define workdir (string->path (git_repository_workdir repo)))
  (make-git_strarray
   (for/list ([path (in-list paths)])
     (relative-pathspec workdir path who))))

(define (make-path-checkout-options repo paths)
  (define options (make-safe-checkout-options))
  ;; `git restore` is explicitly destructive for the selected worktree paths.
  ;; Do not let checkout update the index when restoring only the worktree.
  (set-git_checkout_opts-checkout_strategy!
   options
   '(GIT_CHECKOUT_FORCE GIT_CHECKOUT_DONT_UPDATE_INDEX))
  (set-git_checkout_opts-paths! options (make-pathspecs repo paths 'git-restore))
  options)

(define (split-at-double-dash args)
  (let loop ([before null] [rest args])
    (cond
      [(null? rest) (values (reverse before) #f)]
      [(equal? (car rest) "--") (values (reverse before) (cdr rest))]
      [(eq? (car rest) '--) (values (reverse before) (cdr rest))]
      [else (loop (cons (car rest) before) (cdr rest))])))

(define (git-reset . args)
  (define repo (open-repository))
  (define-values (before paths) (split-at-double-dash args))
  (cond
    [paths
     (when (null? paths)
       (error 'git-reset "expected at least one path after --"))
     (define revision
       (match before
         ['() 'HEAD]
         [(list rev) rev]
         [_ (error 'git-reset "invalid path reset arguments: ~e" args)]))
     (define target (resolve-reset-target repo revision #t))
     (git_reset_default repo target (make-pathspecs repo paths 'git-reset))
     (void)]
    [else
     (define-values (mode revision)
       (match args
         ['() (values 'GIT_RESET_MIXED 'HEAD)]
         [(list '--soft) (values 'GIT_RESET_SOFT 'HEAD)]
         [(list '--mixed) (values 'GIT_RESET_MIXED 'HEAD)]
         [(list '--hard) (values 'GIT_RESET_HARD 'HEAD)]
         [(list '--soft rev) (values 'GIT_RESET_SOFT rev)]
         [(list '--mixed rev) (values 'GIT_RESET_MIXED rev)]
         [(list '--hard rev) (values 'GIT_RESET_HARD rev)]
         [(list rev) (values 'GIT_RESET_MIXED rev)]
         [_ (error 'git-reset "invalid arguments: ~e" args)]))
     (define target (resolve-reset-target repo revision))
     (git_reset repo target mode (make-safe-checkout-options))
     (void)]))

(define (parse-restore-arguments args)
  (let loop ([rest args]
             [staged? #f]
             [worktree? #f]
             [worktree-explicit? #f]
             [source #f]
             [paths null])
    (cond
      [(null? rest)
       (define actual-worktree?
         (if worktree-explicit? worktree? (not staged?)))
       (values staged? actual-worktree? source (reverse paths))]
      [(eq? (car rest) '--staged)
       (loop (cdr rest) #t worktree? worktree-explicit? source paths)]
      [(eq? (car rest) '--worktree)
       (loop (cdr rest) staged? #t #t source paths)]
      [(eq? (car rest) '--source)
       (unless (pair? (cdr rest))
         (error 'git-restore "--source requires a revision"))
       (loop (cddr rest) staged? worktree? worktree-explicit?
             (cadr rest) paths)]
      [(or (eq? (car rest) '--) (equal? (car rest) "--"))
       (values staged?
               (if worktree-explicit? worktree? (not staged?))
               source
               (append (reverse paths) (cdr rest)))]
      [(and (symbol? (car rest))
            (string-prefix? (symbol->string (car rest)) "-"))
       (error 'git-restore "unsupported option: ~a" (car rest))]
      [else
       (loop (cdr rest) staged? worktree? worktree-explicit?
             source (cons (car rest) paths))])))

(define (git-restore . args)
  (define-values (staged? worktree? source paths)
    (parse-restore-arguments args))
  (when (null? paths)
    (error 'git-restore "expected at least one path"))
  (unless (or staged? worktree?)
    (error 'git-restore "nothing to restore"))
  (define repo (open-repository))
  (define source-revision (or source 'HEAD))
  (when staged?
    ;; With an unborn HEAD, a staged restore removes matching new entries from
    ;; the index, which is exactly the useful `git restore --staged` behavior.
    (define target (resolve-reset-target repo source-revision #t))
    (git_reset_default repo target (make-pathspecs repo paths 'git-restore)))
  (when worktree?
    (define options (make-path-checkout-options repo paths))
    (cond
      [(or staged? (not source))
       ;; After a staged restore, or with no explicit source, the index is the
       ;; source for the worktree restore.
       (git_checkout_index repo (git_repository_index repo) options)]
      [else
       (define object
         (with-handlers ([exn:fail?
                          (lambda (_)
                            (error 'git-restore "cannot resolve source: ~a" source))])
           (git_revparse_single repo (revision-string source))))
       (git_checkout_tree repo object options)]))
  (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 (git-branch-create name [start-point "HEAD"])
  (define repo (open-repository))
  (define object
    (with-handlers ([exn:fail?
                     (lambda (_)
                       (error 'git-branch-create
                              "cannot resolve start point: ~a"
                              start-point))])
      (git_revparse_single repo (format "~a^{commit}" start-point))))
  (define commit (git_commit_lookup repo (git_object_id object)))
  (git_branch_create repo name commit #f)
  name)

(define git-branch
  (case-lambda
    [() (git-branches)]
    [(name) (git-branch-create 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 (make-merge-options)
  (define options
    (cast (malloc _git_merge_opts 'atomic) _pointer _git_merge_opts-pointer))
  (git_merge_options_init options GIT-MERGE-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-switch name)
  (unless (member name (git-branches))
    (error 'git-switch "no such local branch: ~a" name))
  (git-checkout name))

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

(define (git-merge name [message #f])
  (define repo (open-repository))
  (define branch (git-current-branch))
  (unless branch
    (error 'git-merge "merge requires an attached local branch"))
  (define ours (head-commit repo))
  (unless ours
    (error 'git-merge "cannot merge into a repository without commits"))
  (define target-object
    (with-handlers ([exn:fail?
                     (lambda (_)
                       (error 'git-merge "cannot resolve merge target: ~a" name))])
      (git_revparse_single repo (format "~a^{commit}" name))))
  (define theirs (git_commit_lookup repo (git_object_id target-object)))
  (define ours-id (git_commit_id ours))
  (define theirs-id (git_commit_id theirs))
  (cond
    ;; The target is already contained in HEAD.
    [(or (git_oid_equal ours-id theirs-id)
         (git_graph_descendant_of repo ours-id theirs-id))
     #f]
    ;; HEAD is an ancestor of the target: do a real fast-forward, including
    ;; index and worktree, and keep HEAD attached to the current branch.
    [(git_graph_descendant_of repo theirs-id ours-id)
     (git_checkout_tree repo target-object (make-safe-checkout-options))
     (define local-ref
       (git_reference_lookup repo (string-append branch-prefix branch)))
     (git_reference_set_target
      local-ref theirs-id (format "merge ~a: fast-forward" name))
     (git_oid_fmt theirs-id)]
    [else
     ;; Build the merge in an in-memory index first. Conflicts therefore leave
     ;; HEAD, the worktree, and the repository index untouched.
     (define merge-index (git_merge_commits repo ours theirs (make-merge-options)))
     (when (git_index_has_conflicts merge-index)
       (error 'git-merge "merge conflicts while merging ~a" name))
     (define tree-id (blank-oid))
     (git_index_write_tree_to tree-id merge-index repo)
     (define tree (git_tree_lookup repo tree-id))
     ;; Safe checkout refuses to overwrite uncommitted worktree changes.
     (git_checkout_tree repo (cast tree _git_tree _git_object)
                        (make-safe-checkout-options))
     (define signature (git_signature_default repo))
     (define commit-id (blank-oid))
     (git_commit_create_v
      commit-id repo "HEAD" signature signature #f
      (or message (format "Merge branch '~a'" name))
      tree 2 ours theirs)
     (git_oid_fmt commit-id)]))

(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 (grep-flag? x flag)
  ;; Racket reads -i as the complex number 0-1i before quote is applied.
  ;; In git-grep option position, accept that reader form as the Git -i flag.
  (or (and (symbol? x) (eq? x flag))
      (and (equal? flag 0-1i) (equal? x 0-1i))))

(define (parse-grep-arguments args)
  (let loop ([rest args] [ignore-case? #f] [invert? #f]
             [show-line-numbers? #f] [files-only? #f] [count? #f])
    (cond
      [(null? rest)
       (error 'git-grep "expected a pattern")]
      [(grep-flag? (car rest) '-i)
       (loop (cdr rest) #t invert? show-line-numbers? files-only? count?)]
      [(grep-flag? (car rest) '-v)
       (loop (cdr rest) ignore-case? #t show-line-numbers? files-only? count?)]
      [(grep-flag? (car rest) '-n)
       (loop (cdr rest) ignore-case? invert? #t files-only? count?)]
      [(grep-flag? (car rest) '-l)
       (loop (cdr rest) ignore-case? invert? show-line-numbers? #t count?)]
      [(grep-flag? (car rest) '-c)
       (loop (cdr rest) ignore-case? invert? show-line-numbers? files-only? #t)]
      [(and (symbol? (car rest))
            (string-prefix? (symbol->string (car rest)) "-"))
       (error 'git-grep "unsupported option: ~a" (car rest))]
      [else
       (define pattern (car rest))
       (define tail (cdr rest))
       (when (> (length tail) 1)
         (error 'git-grep "expected at most one revision after the pattern"))
       (values ignore-case? invert? show-line-numbers? files-only? count?
               pattern (and (pair? tail) (car tail)))])))

(define (grep-regexp pattern ignore-case?)
  (define source
    (cond
      [(regexp? pattern) (object-name pattern)]
      [(byte-regexp? pattern)
       (bytes->string/utf-8 (object-name pattern))]
      [(string? pattern) pattern]
      [else (raise-argument-error 'git-grep "(or/c string? regexp?)" pattern)]))
  (pregexp (if ignore-case? (format "(?i:~a)" source) source)))

(define (binary-bytes? bs)
  (for/or ([b (in-bytes bs)]) (zero? b)))

(define (grep-bytes path bs rx invert?)
  (cond
    [(binary-bytes? bs) null]
    [else
     (define text (bytes->string/utf-8 bs #\uFFFD))
     (for/list ([line (in-list (string-split text "\n" #:trim? #f))]
                [number (in-naturals 1)]
                #:when (if invert?
                           (not (regexp-match? rx line))
                           (regexp-match? rx line)))
       (git-grep-entry path number line))]))

(define (working-tree-grep repo rx invert?)
  (define index (git_repository_index repo))
  (define workdir (git_repository_workdir repo))
  (append*
   (for/list ([i (in-range (git_index_entrycount index))])
     (define entry (git_index_get_byindex index i))
     (define path (git_index_entry-path entry))
     (define full (build-path workdir path))
     (if (file-exists? full)
         (grep-bytes path (file->bytes full) rx invert?)
         null))))

(define (revision-grep repo revision rx invert?)
  (define object
    (with-handlers ([exn:fail?
                     (lambda (_)
                       (error 'git-grep "cannot resolve revision: ~a" revision))])
      (git_revparse_single repo (format "~a^{tree}" revision))))
  (define tree (git_tree_lookup repo (git_object_id object)))
  (define results null)
  (git_tree_walk
   tree 'GIT_TREEWALK_PRE
   (lambda (root entry _payload)
     (when (eq? (git_tree_entry_type entry) 'GIT_OBJECT_BLOB)
       (define path (string-append root (git_tree_entry_name entry)))
       (define blob (git_blob_lookup repo (git_tree_entry_id entry)))
       (set! results
             (append (grep-bytes path (git_blob_rawcontent blob) rx invert?)
                     results)))
     0)
   #"")
  (reverse results))

(define (git-grep . args)
  (define-values (ignore-case? invert? _show-line-numbers? _files-only? _count?
                               pattern revision)
    (parse-grep-arguments args))
  (define rx (grep-regexp pattern ignore-case?))
  (define repo (open-repository))
  (if revision
      (revision-grep repo revision rx invert?)
      (working-tree-grep repo rx invert?)))

(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
    [(version)
     (unless (null? args)
       (error 'git "version takes no arguments"))
     (git-version)]
    [(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)
     (if (and (= (length args) 1) (eq? (car args) '-A))
         (apply git-add (map git-status-entry-path (git 'status)))
         (apply git-add args))]
    [(restore) (apply git-restore args)]
    [(reset) (apply git-reset args)]
    [(config) (apply git-config args)]
    [(commit) (apply git-commit args)]
    [(branch-current)
     (unless (null? args)
       (error 'git "branch-current takes no arguments"))
     (git-current-branch)]
    [(branch)
     (match args
       [(list '-d name) (git-branch-delete name)]
       [_ (apply git-branch args)])]
    [(branch-create) (apply git-branch-create args)]
    [(switch) (apply git-switch args)]
    [(merge) (apply git-merge 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)])]
    [(grep) (apply git-grep 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 (display-grep-result args result [out (current-output-port)])
  (define files-only? (member '-l args))
  (define count? (member '-c args))
  (define line-numbers? (member '-n args))
  (cond
    [files-only?
     (for ([path (in-list (remove-duplicates (map git-grep-entry-path result)))])
       (displayln path out))]
    [count?
     (define counts (make-hash))
     (for ([entry (in-list result)])
       (hash-update! counts (git-grep-entry-path entry) add1 0))
     (for ([path (in-list (sort (hash-keys counts) string<?))])
       (fprintf out "~a:~a\n" path (hash-ref counts path)))]
    [else
     (for ([entry (in-list result)])
       (if line-numbers?
           (fprintf out "~a:~a:~a\n"
                    (git-grep-entry-path entry)
                    (git-grep-entry-line-number entry)
                    (git-grep-entry-line entry))
           (fprintf out "~a:~a\n"
                    (git-grep-entry-path entry)
                    (git-grep-entry-line entry))))]))

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