1370 lines
49 KiB
Racket
1370 lines
49 KiB
Racket
#lang racket/base
|
|
|
|
(require ffi/unsafe
|
|
racket/runtime-path
|
|
setup/getinfo
|
|
racket/async-channel
|
|
racket/list
|
|
racket/file
|
|
racket/match
|
|
racket/path
|
|
racket/string
|
|
net/sendurl
|
|
setup/xref
|
|
scribble/xref
|
|
"credentials.rkt"
|
|
libgit2)
|
|
|
|
(provide git
|
|
dgit
|
|
git-version
|
|
git-help
|
|
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 git-help-bindings
|
|
(hash 'version 'git-version
|
|
'init 'git-init
|
|
'clone 'git-clone
|
|
'status 'git-status
|
|
'diff 'git-diff
|
|
'add 'git-add
|
|
'restore 'git-restore
|
|
'reset 'git-reset
|
|
'grep 'git-grep
|
|
'config 'git-config
|
|
'commit 'git-commit
|
|
'branch-current 'git-current-branch
|
|
'branch 'git-branch
|
|
'branch-create 'git-branch-create
|
|
'switch 'git-switch
|
|
'checkout 'git-checkout
|
|
'merge 'git-merge
|
|
'tag 'git-tag
|
|
'log 'git-log
|
|
'remote 'git-remotes
|
|
'fetch 'git-fetch
|
|
'pull 'git-pull
|
|
'push 'git-push
|
|
'push-tag 'git-push-tag
|
|
'credentials 'git-credentials-init!
|
|
'prompt 'git-prompt
|
|
'git-prompt 'git-prompt
|
|
'help 'git-help))
|
|
|
|
(define (git-help [topic #f])
|
|
(unless (or (not topic) (symbol? topic))
|
|
(raise-argument-error 'git-help "(or/c #f symbol?)" topic))
|
|
(define binding
|
|
(if topic
|
|
(hash-ref git-help-bindings topic
|
|
(lambda ()
|
|
(error 'git-help "unknown help topic: ~a" topic)))
|
|
'git))
|
|
;; Use Racket's installed-documentation cross-reference database instead of
|
|
;; guessing where raco setup placed this package's generated HTML.
|
|
(define xref (load-collections-xref))
|
|
(define tag
|
|
(xref-binding->definition-tag xref (list 'git binding) #f))
|
|
(unless tag
|
|
(error 'git-help
|
|
"documentation for ~a is not indexed; run raco setup git"
|
|
binding))
|
|
(define-values (path anchor)
|
|
(xref-tag->path+anchor xref tag))
|
|
(unless path
|
|
(error 'git-help
|
|
"documentation for ~a is indexed but has no local path"
|
|
binding))
|
|
(send-url/file path #:fragment anchor)
|
|
(void))
|
|
|
|
(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)]
|
|
[(help)
|
|
(match args
|
|
['() (git-help)]
|
|
[(list topic) (git-help topic)]
|
|
[_ (error 'git "help takes zero or one topic")])]
|
|
[(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)
|