hans/git-cli
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added credentials

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-10 15:46:39 +02:00
parent 4689c56e4d
commit a72604e290
8 changed files with 190 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README.md
+2
View File
@@ -6,6 +6,8 @@ A small command-line-like Git module for Racket, implemented directly on top of
(require git)
(git 'status)
(git 'diff)
(git 'diff '--cached)
(git 'add "main.rkt" "info.rkt")
(git 'commit "Implement raco support")
(git 'tag "v0.2")
credentials.rkt
+8
View File
@@ -18,6 +18,7 @@
git-credentials-unlock-expires
git-credentials-set!
git-credentials-ref
git-credentials-configured?
git-credentials-remove!)
(define git-credentials-store 'racket-git)
@@ -199,6 +200,13 @@
(store-write (current-git-credentials-store) ini)
(void))
(define (git-credentials-configured? remote)
(define section (credential-section remote))
(define username (store-get (current-git-credentials-store) section 'username #f))
(define encrypted (store-get (current-git-credentials-store) section 'token #f))
(and (string? username) (not (string=? username ""))
(string? encrypted) (not (string=? encrypted ""))))
(define (git-credentials-ref remote)
(define section (credential-section remote))
(define username (store-get (current-git-credentials-store) section 'username #f))
info.rkt
+1 -1
View File
@@ -2,7 +2,7 @@
(define collection "git")
(define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2")
(define version "0.2.2")
(define version "0.2.5")
(define pkg-authors '("Hans Dijkema"))
(define license 'MIT)
main.rkt
+115 -52
View File
@@ -6,10 +6,7 @@
racket/path
racket/string
"credentials.rkt"
(except-in libgit2 git_remote_push)
(only-in libgit2/private/base
define-libgit2
_git_error_code/check))
libgit2)
(provide git
dgit
@@ -21,6 +18,7 @@
git-status
git-status-lines
git-clean?
git-diff
git-add
git-config
git-config-get
@@ -53,25 +51,12 @@
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)
;; The current Racket libgit2 package has an incorrect Scheme -> C
;; conversion for git_strarray pointers. Keep this tiny corrected binding
;; local to this module for push refspecs.
(define-cstruct _git_strarray/raw
([strings _pointer]
[count _size]))
(define-libgit2 git_remote_push/raw
(_fun _git_remote
_git_strarray/raw-pointer
_git_push_opts-pointer
-> (_git_error_code/check))
#:c-id git_remote_push)
(define zero-oid-string (make-string GIT_OID_HEXSZ #\0))
(define branch-prefix "refs/heads/")
(define tag-prefix "refs/tags/")
@@ -81,25 +66,31 @@
(define GIT-PASSTHROUGH -30)
(define (git-credential-callback out url username-from-url allowed-types _payload)
(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)))
(ptr-set! out _git_credential
(git_credential_username_new username))
0]
[else GIT-PASSTHROUGH])]))
;; 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)
(set-git_remote_callbacks-credentials! callbacks git-credential-callback)
@@ -238,6 +229,35 @@
(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) "/"))
@@ -323,14 +343,13 @@
(define signature (git_signature_default repo))
(define commit-id (blank-oid))
(define result
(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)))
(unless (zero? result)
(error 'git-commit "libgit2 git_commit_create_v failed with code ~a" result))
(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)
@@ -486,7 +505,21 @@
(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 (git-fetch [name "origin"])
(check-remote-credentials 'git-fetch name)
(define repo (open-repository))
(define remote (git_remote_lookup repo name))
(git_remote_fetch remote #f (make-fetch-options) (format "fetch ~a" name))
@@ -520,16 +553,42 @@
(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 (push-refspec remote-name refspec)
(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))
(define repo (open-repository))
(define remote (git_remote_lookup repo remote-name))
(define options (make-push-options))
(define strings
(cast (list refspec) (_list i _string interior) _gcpointer))
(define refspecs (make-git_strarray/raw strings 1))
(git_remote_push/raw remote refspecs options)
;; Keep the C string-pointer array alive through the foreign call.
(void strings)
;; 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))
(git_remote_push remote #f options))
(lambda ()
(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))))))
(void))
(define git-push
@@ -564,6 +623,7 @@
[(init) (apply git-init args)]
[(clone) (apply git-clone args)]
[(status) (apply git-status args)]
[(diff) (apply git-diff args)]
[(add) (apply git-add args)]
[(config) (apply git-config args)]
[(commit) (apply git-commit args)]
@@ -600,6 +660,7 @@
[(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)]))
@@ -632,6 +693,8 @@
(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"
scribblings/git.scrbl
+6
View File
@@ -15,6 +15,8 @@ The short form is intended for build scripts and interactive use:
(require git)
(git 'status)
(git 'diff)
(git 'diff '--cached)
(git 'add "main.rkt" "info.rkt")
(git 'commit "Implement raco support")
(git 'tag "v0.1")
@@ -54,6 +56,10 @@ Calls @racket[git], displays its result in a compact human-readable form, and re
@defproc[(git-clean?) boolean?]{Returns @racket[#t] when @racket[git-status] is empty.}
@defproc*([[(git-diff) string?]
[(git-diff [option (or/c '--cached)]) string?]])]{Returns a unified patch as a string. With no arguments it compares the index with the worktree, like @tt{git diff}. With @racket['--cached] it compares HEAD with the index, like @tt{git diff --cached}.}
@defproc[(git-add [path path-string?] ...) void?]{Stages the given paths. With no paths, stages the whole repository, including tracked removals.}
@section{Configuration and commits}
tests/basic.rkt
+23 -1
View File
@@ -52,6 +52,28 @@
(define first (git-commit "initial commit"))
(check-equal? (string-length first) 40)
(check-true (git-clean?))
(check-equal? (git 'diff) "")
(check-equal? (git 'diff '--cached) "")
(call-with-output-file (build-path "sub" "hello.txt")
#:exists 'truncate/replace
(lambda (out) (displayln "changed" out)))
(define worktree-diff (git 'diff))
(check-true (regexp-match? #rx"-hello" worktree-diff))
(check-true (regexp-match? #rx"\+changed" worktree-diff))
(check-equal? (git 'diff '--cached) "")
(define diff-output (open-output-string))
(parameterize ([current-output-port diff-output])
(dgit 'diff))
(check-equal? (get-output-string diff-output) worktree-diff)
(git 'add "sub/hello.txt")
(check-equal? (git 'diff) "")
(define cached-diff (git 'diff '--cached))
(check-true (regexp-match? #rx"-hello" cached-diff))
(check-true (regexp-match? #rx"\+changed" cached-diff))
(git 'commit "prepare branches")
(git 'checkout '-b "work")
(call-with-output-file (build-path "sub" "hello.txt")
@@ -78,6 +100,6 @@
(git 'tag '-d "v0.1")
(check-equal? (git 'tag) '())
(check-equal? (length (git 'log 10)) 1)))
(check-equal? (length (git 'log 10)) 2)))
(lambda ()
(delete-directory/files tmp)))
tests/remote.rkt
+17
View File
@@ -76,3 +76,20 @@
(check-false (file-exists? "remote.txt"))))
(lambda ()
(delete-directory/files tmp)))
;; HTTPS push without configured credentials must fail before entering libgit2.
(let ([tmp2 (make-temporary-file "racket-git-https-test~a" 'directory)])
(dynamic-wind
void
(lambda ()
(parameterize ([current-directory tmp2])
(git 'init)
(configure!)
(call-with-output-file "x.txt" #:exists 'truncate/replace
(lambda (out) (displayln "x" out)))
(git 'add "x.txt")
(git 'commit "x")
(git 'remote 'add "origin" "https://example.invalid/private/repo.git")
(check-exn #rx"no HTTPS credentials are stored"
(lambda () (git 'push)))))
(lambda () (delete-directory/files tmp2))))
tests/stress-commit.rkt
+18
View File
@@ -0,0 +1,18 @@
#lang racket/base
(require racket/file rackunit git)
(define tmp (make-temporary-file "racket-git-stress~a" 'directory))
(dynamic-wind
void
(lambda ()
(parameterize ([current-directory tmp])
(git 'init)
(git 'config "user.name" "Stress Test")
(git 'config "user.email" "stress@example.invalid")
(for ([i (in-range 50)])
(call-with-output-file "counter.txt" #:exists 'truncate/replace
(lambda (out) (fprintf out "~a\n" i)))
(git 'add "counter.txt")
(define oid (git 'commit (format "commit ~a" i)))
(check-equal? (string-length oid) 40))
(check-equal? (length (git 'log 100)) 50)))
(lambda () (delete-directory/files tmp)))