From a72604e290eb8b5d7ffbd7b7640d93192d6b68ad Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Mon, 10 Aug 2026 15:46:39 +0200 Subject: [PATCH] Added credentials --- README.md | 2 + credentials.rkt | 8 ++ info.rkt | 2 +- main.rkt | 167 +++++++++++++++++++++++++++------------- scribblings/git.scrbl | 6 ++ tests/basic.rkt | 24 +++++- tests/remote.rkt | 17 ++++ tests/stress-commit.rkt | 18 +++++ 8 files changed, 190 insertions(+), 54 deletions(-) create mode 100644 tests/stress-commit.rkt diff --git a/README.md b/README.md index 1a804d2..6a3faf7 100644 --- a/README.md +++ b/README.md @@ -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") diff --git a/credentials.rkt b/credentials.rkt index c19df6a..a02e447 100644 --- a/credentials.rkt +++ b/credentials.rkt @@ -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)) diff --git a/info.rkt b/info.rkt index f62b014..2653a97 100644 --- a/info.rkt +++ b/info.rkt @@ -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) diff --git a/main.rkt b/main.rkt index 79515a9..db25854 100644 --- a/main.rkt +++ b/main.rkt @@ -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 )" + 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)) (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" diff --git a/scribblings/git.scrbl b/scribblings/git.scrbl index 55e7189..edd1266 100644 --- a/scribblings/git.scrbl +++ b/scribblings/git.scrbl @@ -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} diff --git a/tests/basic.rkt b/tests/basic.rkt index 647448e..af006a9 100644 --- a/tests/basic.rkt +++ b/tests/basic.rkt @@ -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))) diff --git a/tests/remote.rkt b/tests/remote.rkt index 338d75d..9c44a5f 100644 --- a/tests/remote.rkt +++ b/tests/remote.rkt @@ -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)))) diff --git a/tests/stress-commit.rkt b/tests/stress-commit.rkt new file mode 100644 index 0000000..27ea9e6 --- /dev/null +++ b/tests/stress-commit.rkt @@ -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)))