923 lines
32 KiB
Racket
923 lines
32 KiB
Racket
#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)
|
|
(if (and (= (length args) 1) (eq? (car args) '-A))
|
|
(apply git-add (map git-status-entry-path (git 'status)))
|
|
(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)
|