From 6f558868a1d159b4a95294a6b814e89495eafab5 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Wed, 12 Aug 2026 10:23:53 +0200 Subject: [PATCH] Restarting --- README.md | 99 --- credentials.rkt | 230 ------- info.rkt | 9 +- main.rkt | 1371 +-------------------------------------- scribblings/git.scrbl | 267 -------- tests/basic.rkt | 189 ------ tests/branch-merge.rkt | 70 -- tests/credentials.rkt | 30 - tests/grep-reader.rkt | 32 - tests/remote.rkt | 140 ---- tests/stress-commit.rkt | 18 - 11 files changed, 4 insertions(+), 2451 deletions(-) delete mode 100644 credentials.rkt delete mode 100644 tests/basic.rkt delete mode 100644 tests/branch-merge.rkt delete mode 100644 tests/credentials.rkt delete mode 100644 tests/grep-reader.rkt delete mode 100644 tests/remote.rkt delete mode 100644 tests/stress-commit.rkt diff --git a/README.md b/README.md index ab2e41d..fc21cc5 100644 --- a/README.md +++ b/README.md @@ -47,102 +47,3 @@ documentation cross-reference index: (git 'help 'grep) (git 'help 'restore) ``` - -`raco setup git` builds and indexes the package documentation. The help command -builds a fresh cross-reference view for each request, so documentation generated -during the current DrRacket session is visible immediately. It uses the indexed -path and anchor instead of assuming a particular documentation directory. - -## HTTPS credentials - -Version 0.2 adds persistent HTTPS credentials. They are stored in the -`racket-git.ini` file in Racket's preferences directory. Tokens are encrypted -with AES-GCM using a key derived from the store password with -PBKDF2-HMAC-SHA256. - -Create the credential store once: - -```racket -(git 'credentials 'init "store password") -``` - -Store a token for a Git host: - -```racket -(git 'credentials 'set - "https://git.dijkewijk.nl" - "hans" - token) -``` - -The host is used as the credential key, so the same entry is used for all HTTPS -repositories on that host. - -The store is unlocked for one day by default: - -```racket -(git 'credentials 'unlock "store password") -``` - -or for an explicit number of seconds: - -```racket -(git 'credentials 'unlock "store password" (* 8 60 60)) -``` - -The temporary unlock state is stored in `racket-git-unlock.ini` in Racket's -preferences directory, so it survives restarting DrRacket and starting a new -Racket process. Both files are opened through `simple-ini` with `#:private? #t`; on Unix this -restricts them to mode 0600 before sensitive contents are written. The cached -derived key grants access to the credentials until its expiry, -so `racket-git-unlock.ini` must be treated as sensitive during that period. - -Lock immediately with: - -```racket -(git 'credentials 'lock) -``` - -After credentials have been stored and the store is unlocked, normal remote -operations use them automatically: - -```racket -(git 'fetch) -(git 'pull) -(git 'push) -;; Example while a real push is in progress: -;; [git] push origin/main: compressing 45% (37/82 objects) -;; [git] push origin/main: sending 58% (48/82 objects) - -;; Suppress network progress when desired: -(git 'push #:quiet #t) -``` - -## Supported Git operations - -Version 0.2 supports help, repository discovery, init, clone, status, diff, add, restore, reset, grep, config, -commit, branch, branch-current, switch, checkout, merge, lightweight tags, log, remotes, fetch, -fast-forward-only pull, push, tag push, network transfer progress, and HTTPS username/token credentials. - -SSH credentials, merge/rebase pull, annotated tags, and submodules are not yet -part of this module. - -Install from the package directory with: - -```sh -raco pkg install . -``` - - -## Recover a detached HEAD commit - -```racket -(git 'branch-current) ; #f -(git 'branch-create "rescue-readme") -(git 'switch "main") -(git 'merge "rescue-readme") -(git 'status) -(dgit 'log 5) -(git 'push) -(git 'branch '-d "rescue-readme") -``` diff --git a/credentials.rkt b/credentials.rkt deleted file mode 100644 index a02e447..0000000 --- a/credentials.rkt +++ /dev/null @@ -1,230 +0,0 @@ -#lang racket/base - -(require crypto - crypto/all - net/base64 - racket/file - racket/string - simple-ini) - -(provide git-credentials-store - git-credentials-unlock-store - current-git-credentials-store - current-git-credentials-unlock-store - 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!) - -(define git-credentials-store 'racket-git) -(define git-credentials-unlock-store 'racket-git-unlock) - -;; Parameters make the storage location overridable for tests or embedded use, -;; while the public default remains the normal Racket preference stores. -(define current-git-credentials-store (make-parameter git-credentials-store)) -(define current-git-credentials-unlock-store (make-parameter git-credentials-unlock-store)) - -(define settings-section 'settings) -(define unlock-section 'unlock) -(define kdf-iterations 200000) -(define cipher '(aes gcm)) -(define check-text #"racket-git credential store") - -(define-syntax-rule (with-git-crypto body ...) - (parameterize ([crypto-factories all-factories]) - body ...)) - -(define (b64-encode bytes) - (bytes->string/utf-8 (base64-encode bytes #""))) - -(define (b64-decode string) - (base64-decode (string->bytes/utf-8 string))) - -(define (store-read name) - (file->ini name)) - -(define (store-write name ini) - (make-directory* (find-system-path 'pref-dir)) - (ini->file ini name #:private? #t) - (void)) - -(define (store-set! name section key value) - (define ini (store-read name)) - (ini-set! ini section key value) - (store-write name ini)) - -(define (store-get name section key [default #f]) - (ini-get (store-read name) section key default)) - -(define (derive-key password salt) - (with-git-crypto - (pbkdf2-hmac 'sha256 - (string->bytes/utf-8 password) - salt - #:iterations kdf-iterations - #:key-size 32))) - -(define (encrypt-value key plaintext aad) - (with-git-crypto - (define iv (generate-cipher-iv cipher)) - (define encrypted - (encrypt cipher key iv (string->bytes/utf-8 plaintext) - #:aad (string->bytes/utf-8 aad))) - (string-append (b64-encode iv) ":" (b64-encode encrypted)))) - -(define (decrypt-value key encoded aad) - (with-git-crypto - (define parts (string-split encoded ":")) - (unless (= (length parts) 2) - (error 'git-credentials "invalid encrypted credential data")) - (bytes->string/utf-8 - (decrypt cipher key - (b64-decode (car parts)) - (b64-decode (cadr parts)) - #:aad (string->bytes/utf-8 aad))))) - -(define (credential-key remote) - (define url-match - (regexp-match #px"^[A-Za-z][A-Za-z0-9+.-]*://(?:[^/@]+@)?([^/:]+)" remote)) - (define ssh-match - (regexp-match #px"^[^@]+@([^:]+):" remote)) - (string-downcase - (cond - [url-match (cadr url-match)] - [ssh-match (cadr ssh-match)] - [else remote]))) - -(define (string->hex string) - (apply string-append - (for/list ([b (in-bytes (string->bytes/utf-8 string))]) - (let ([h (number->string b 16)]) - (if (= (string-length h) 1) (string-append "0" h) h))))) - -(define (credential-section remote) - ;; simple-ini deliberately accepts a conservative section-name syntax. - ;; Hex keeps arbitrary host names reversible and section-safe. - (string->symbol (string-append "credential." - (string->hex (credential-key remote))))) - -(define (git-credentials-init! password #:unlock-for [seconds 86400]) - (unless (and (string? password) (positive? (string-length password))) - (raise-argument-error 'git-credentials-init! "non-empty string?" password)) - (define existing-salt (store-get (current-git-credentials-store) settings-section 'salt #f)) - (when existing-salt - (error 'git-credentials-init! "credential store is already initialized")) - (define salt (with-git-crypto (crypto-random-bytes 16))) - (define key (derive-key password salt)) - (define ini (store-read (current-git-credentials-store))) - (ini-set! ini settings-section 'version 1) - (ini-set! ini settings-section 'kdf "pbkdf2-hmac-sha256") - (ini-set! ini settings-section 'iterations kdf-iterations) - (ini-set! ini settings-section 'salt (b64-encode salt)) - (ini-set! ini settings-section 'check - (encrypt-value key (bytes->string/utf-8 check-text) "check")) - (store-write (current-git-credentials-store) ini) - (cache-unlock-key! key seconds) - (void)) - -(define (cache-unlock-key! key seconds) - (unless (and (real? seconds) (> seconds 0)) - (raise-argument-error 'git-credentials-unlock! "positive real?" seconds)) - (define ini (store-read (current-git-credentials-unlock-store))) - (ini-set! ini unlock-section 'key (b64-encode key)) - (ini-set! ini unlock-section 'expires (+ (current-seconds) seconds)) - (store-write (current-git-credentials-unlock-store) ini) - (void)) - -(define (git-credentials-unlock! password #:for [seconds 86400]) - (define salt-text (store-get (current-git-credentials-store) settings-section 'salt #f)) - (define check (store-get (current-git-credentials-store) settings-section 'check #f)) - (unless (and salt-text check) - (error 'git-credentials-unlock! "credential store is not initialized")) - (define key (derive-key password (b64-decode salt-text))) - (with-handlers ([exn:fail? - (lambda (_) - (error 'git-credentials-unlock! "invalid password"))]) - (unless (string=? (decrypt-value key check "check") - (bytes->string/utf-8 check-text)) - (error 'git-credentials-unlock! "invalid password"))) - (cache-unlock-key! key seconds) - (void)) - -(define (git-credentials-lock!) - (define ini (store-read (current-git-credentials-unlock-store))) - (ini-set! ini unlock-section 'key "") - (ini-set! ini unlock-section 'expires 0) - (store-write (current-git-credentials-unlock-store) ini) - (void)) - -(define (git-credentials-unlock-expires) - (define expires (store-get (current-git-credentials-unlock-store) unlock-section 'expires 0)) - (if (number? expires) expires 0)) - -(define (git-credentials-unlocked?) - (define key (store-get (current-git-credentials-unlock-store) unlock-section 'key "")) - (define expires (git-credentials-unlock-expires)) - (cond - [(and (string? key) - (not (string=? key "")) - (> expires (current-seconds))) - #t] - [else - (when (and (number? expires) (positive? expires)) - (git-credentials-lock!)) - #f])) - -(define (current-key who) - (unless (git-credentials-unlocked?) - (error who "credential store 'racket-git is locked")) - (b64-decode - (store-get (current-git-credentials-unlock-store) unlock-section 'key ""))) - -(define (git-credentials-set! remote username token) - (unless (string? remote) - (raise-argument-error 'git-credentials-set! "string?" remote)) - (unless (string? username) - (raise-argument-error 'git-credentials-set! "string?" username)) - (unless (string? token) - (raise-argument-error 'git-credentials-set! "string?" token)) - (define key (current-key 'git-credentials-set!)) - (define section (credential-section remote)) - (define ini (store-read (current-git-credentials-store))) - (ini-set! ini section 'username username) - (ini-set! ini section 'token - (encrypt-value key token (string-append (credential-key remote) ":" username))) - (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)) - (define encrypted (store-get (current-git-credentials-store) section 'token #f)) - (cond - [(and (string? username) (not (string=? username "")) - (string? encrypted) (not (string=? encrypted ""))) - (define key (current-key 'git-credentials-ref)) - (cons username - (decrypt-value key encrypted (string-append (credential-key remote) ":" username)))] - [else #f])) - -(define (git-credentials-remove! remote) - ;; simple-ini has no section-delete primitive. Clearing both values keeps - ;; the file format simple and makes git-credentials-ref return #f. - (define section (credential-section remote)) - (define ini (store-read (current-git-credentials-store))) - (ini-set! ini section 'username "") - (ini-set! ini section 'token "") - (store-write (current-git-credentials-store) ini) - (void)) diff --git a/info.rkt b/info.rkt index b0901d0..d814c88 100644 --- a/info.rkt +++ b/info.rkt @@ -1,17 +1,14 @@ #lang info -(define collection "git") -(define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2") -(define version "0.2.16") +(define collection "git-cli") +(define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command") +(define version "0.3.1") (define pkg-authors '("Hans Dijkema")) (define license 'MIT) (define deps '("base" - "libgit2" ("simple-ini" #:version "0.3.3") - "crypto-lib" - "net-lib" "racket-index" "scribble-lib" "racket-makefile" diff --git a/main.rkt b/main.rkt index f83e398..2385e5f 100644 --- a/main.rkt +++ b/main.rkt @@ -1,1370 +1 @@ -#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)) - ;; Build a fresh installed-documentation cross-reference database instead of - ;; using load-collections-xref's process-local cache. This makes help notice - ;; documentation generated by raco setup during the current DrRacket session. - (define xref (make-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) - (stringstring 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 stringstring (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)" - 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)) - (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 "0.2.16" -] - -@section[#:tag "repository"]{Repository} - -@defproc[(git-repository? [path path-string? (current-directory)]) boolean?]{Returns whether @racket[path] is inside a Git repository.} - -@defproc[(git-root [path path-string? (current-directory)]) path?]{Returns the repository worktree root.} - -@defproc[(git-init [path path-string? (current-directory)] [#:bare? bare? any/c #f]) path?]{Initializes a repository.} - -@defproc*[([(git-clone [url string?] [#:quiet quiet any/c #f]) path?] - [(git-clone [url string?] [path path-string?] [#:quiet quiet any/c #f]) path?])]{Clones @racket[url]. If @racket[path] is omitted, a directory name is derived from the URL. Progress is written to the current output port unless @racket[quiet] is true.} - -@section[#:tag "status"]{Status} - -@defstruct*[git-status-entry ([path string?] [code string?] [flags list?])]{Describes one status entry. The @racket[code] field uses the familiar two-character Git status notation.} - -@defproc[(git-status) (listof git-status-entry?)]{Returns worktree and index status.} - -@defproc[(git-status-lines [entries (listof git-status-entry?) (git-status)]) (listof string?)]{Formats status entries as short Git-like lines.} - -@defproc[(git-clean?) boolean?]{Returns @racket[#t] when @racket[git-status] is empty.} - -@section[#:tag "diff"]{Diff} - -@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}.} - - -@section[#:tag "add"]{Add} - -@defproc[(git-add [path path-string?] ...) void?]{Stages the given paths. With no paths, stages the whole repository, including tracked removals. The command form @racket[(git 'add '-A)] stages all current status entries, including new, modified, and removed paths.} - -@racketblock[ -(git 'add '-A) -(git 'commit "Update all changed files") -] - -@section[#:tag "restore"]{Restore} - -@defproc[(git-restore [argument any/c] ...) void?]{Restores paths using Git-like command arguments. With only paths, the worktree is restored from the index, as in @tt{git restore path}. With @racket['--staged], matching index entries are restored from HEAD while the worktree is left untouched. @racket['--worktree] can be combined with @racket['--staged], and @racket['--source] selects another revision.} - -@racketblock[ -(git 'restore "main.rkt") -(git 'restore '--staged "scrbl/racket-makefile.bak") -(git 'restore '--source "HEAD~1" "main.rkt") -] - -@section[#:tag "reset"]{Reset} - -@defproc[(git-reset [argument any/c] ...) void?]{Resets HEAD, the index, or selected paths using Git-like command arguments. With @racket['--soft], @racket['--mixed], or @racket['--hard], the corresponding whole-repository reset is performed. Path resets use the familiar @tt{--} separator.} - -@racketblock[ -(git 'reset 'HEAD "--" "main.rkt") -(git 'reset '--mixed 'HEAD) -(git 'reset '--hard 'HEAD) -] - -@section[#:tag "grep"]{Grep} - -@defstruct*[git-grep-entry ([path string?] [line-number exact-positive-integer?] [line string?])]{Describes one line selected by @racket[git-grep]. Results are always structured this way, regardless of display-oriented flags such as @racket['-n], @racket['-l], or @racket['-c].} - -@defproc[(git-grep [argument any/c] ...) (listof git-grep-entry?)]{Searches tracked files in the current worktree, or in an optional revision supplied after the pattern. String patterns are regular expressions. @racket['-i] makes matching case-insensitive and @racket['-v] inverts the match. The flags @racket['-n], @racket['-l], and @racket['-c] do not change the structured result; they control how @racket[dgit] displays it. Binary files are skipped. Racket's reader normally reads @tt{-i} as the complex number @racket[0-1i]; @racket[git-grep] deliberately recognizes that value in option position as Git's @tt{-i} flag, so the natural @racket['-i] spelling works.} - -@racketblock[ -(git 'grep "TODO") -(git 'grep '-i "todo") -(git 'grep '-v "generated") -(git 'grep "old-name" 'HEAD~1) - -(dgit 'grep '-n "TODO") ; path:line-number:text -(dgit 'grep '-l "TODO") ; matching file names only -(dgit 'grep '-c "TODO") ; number of matching lines per file -] - -@section[#:tag "config"]{Configuration} - -@defproc*[([(git-config [key string?]) string?] - [(git-config [key string?] [value string?]) string?])]{Reads or writes a repository configuration value. The two-argument form returns @racket[value].} - -@defproc[(git-head) (or/c string? #f)]{Returns the full OID of HEAD, or @racket[#f] for a repository without commits.} - -@section[#:tag "commit"]{Commit} - -@defproc[(git-commit [message string?]) string?]{Creates a commit from the index and returns its full OID. The author and committer are read from the repository configuration.} - - -@subsection[#:tag "git-prompt"]{Commit prompt} - -@defproc[(git-prompt [message string? #f]) string?]{Returns @racket[message] when supplied. Without an argument, displays @tt{Give (commit) message: }, reads one line from the current input port, and returns it. This is convenient in interactive make targets before staging and committing changes.} - -@section[#:tag "branches"]{Branches} - -@defproc[(git-current-branch) (or/c string? #f)]{Returns the current local branch name, or @racket[#f] for detached HEAD. The command form is @racket[(git 'branch-current)].} - -@defproc*[([(git-branch) (listof string?)] - [(git-branch [name string?]) string?])]{Lists local branches, or creates @racket[name] at HEAD.} - -@defproc[(git-branch-create [name string?] [start-point string? "HEAD"]) string?]{Creates a local branch named @racket[name] at @racket[start-point] and returns @racket[name]. The default start point is the current HEAD, including detached HEAD. The command forms are @racket[(git 'branch-create name)] and @racket[(git 'branch-create name start-point)].} - -@defproc[(git-branch-delete [name string?]) void?]{Deletes a local branch. The command form is @racket[(git 'branch '-d name)].} - -@section[#:tag "switch-checkout"]{Switch and checkout} - -@defproc[(git-switch [name string?]) (or/c string? #f)]{Switches to an existing local branch and attaches HEAD to that branch. The command form is @racket[(git 'switch name)]. An unknown local branch raises an exception.} - -@defproc[(git-checkout [name string?]) (or/c string? #f)]{Checks out a local branch, tag, or commit. A tag or commit produces detached HEAD.} - -@defproc[(git-checkout-new [name string?]) string?]{Creates and checks out a new branch.} - -@section[#:tag "merge"]{Merge} - -@defproc[(git-merge [name string?] [message (or/c string? #f) #f]) (or/c string? #f)]{Merges @racket[name] into the currently attached local branch. An up-to-date merge returns @racket[#f]. A fast-forward returns the new HEAD OID. A clean non-fast-forward merge creates a two-parent merge commit and returns its OID. If @racket[message] is @racket[#f], the merge commit message is @tt{Merge branch 'name'}. Conflicting merges raise an exception before changing HEAD or the worktree. The command forms are @racket[(git 'merge name)] and @racket[(git 'merge name message)].} - -@section[#:tag "tags"]{Tags} - -@defproc*[([(git-tag) (listof string?)] - [(git-tag [name string?]) string?])]{Lists tags, or creates a lightweight tag at HEAD and returns its OID.} - -@defproc[(git-tag-delete [name string?]) void?]{Deletes a tag.} - -@subsection{Recovering a commit made with detached HEAD} - -A commit made while HEAD is detached is not attached to a local branch. The following sequence gives the commit a temporary branch name, switches back to @tt{main}, merges the rescued commit, verifies the result, pushes it, and removes the temporary branch: - -@racketblock[ -(git 'branch-current) ; => #f -(git 'branch-create "rescue-readme") -(git 'switch "main") -(git 'merge "rescue-readme") -(git 'status) -(dgit 'log 5) -(git 'push) -(git 'branch '-d "rescue-readme") -] - -The @racket[(dgit 'log 5)] form is the compact Racket equivalent of using a short command-line log for verification: it displays the abbreviated commit OID and summary for the five newest commits. - -@section[#:tag "log"]{Log} - -@defstruct*[git-log-entry ([id string?] [summary string?] [time integer?])]{Describes one commit returned by @racket[git-log].} - -@defproc[(git-log [max-count exact-nonnegative-integer? 20]) (listof git-log-entry?)]{Returns commits from HEAD in topological/time order.} - -@defproc[(git-log-lines [entries (listof git-log-entry?) (git-log)]) (listof string?)]{Formats log entries as short OID plus summary.} - -@section[#:tag "remotes"]{Remotes} - -@defproc[(git-remotes) (listof string?)]{Lists remotes.} - -@defproc[(git-remote-add [name string?] [url string?]) string?]{Adds a remote.} - -@defproc[(git-remote-url [name string? "origin"]) string?]{Returns the remote URL.} - -@defproc[(git-fetch [remote string? "origin"] [#:quiet quiet any/c #f]) void?]{Fetches the configured refspecs from a remote. Progress is written to the current output port unless @racket[quiet] is true.} - -@defproc[(git-pull [remote string? "origin"] [#:quiet quiet any/c #f]) (or/c string? #f)]{Fetches and performs a fast-forward-only update of the current branch. Returns the new OID, or @racket[#f] when already up to date. A non-fast-forward update raises an exception.} - -@defproc[(git-push [remote string? "origin"] [branch (or/c string? #f) #f] [#:quiet quiet any/c #f]) void?]{Pushes a branch to a branch with the same name. With no positional arguments, the current branch is pushed to @tt{origin}; with only @racket[remote], the current branch is pushed there. A start and completion message and transfer progress are written to the current output port unless @racket[quiet] is true. Progress callbacks only record transfer state; the libgit2 operation runs in a parallel Racket thread while the calling Racket thread performs output outside FFI callback context. Push progress distinguishes packing/compression from sending when libgit2 reports those phases.} - -@defproc[(git-push-tag [tag string?] [remote string? "origin"] [#:quiet quiet any/c #f]) void?]{Pushes one tag. A start and completion message and transfer progress are written to the current output port unless @racket[quiet] is true. Progress callbacks only record transfer state; the libgit2 operation runs in a parallel Racket thread while the calling Racket thread performs output outside FFI callback context. Push progress distinguishes packing/compression from sending when libgit2 reports those phases.} - -Remote HTTPS operations automatically use credentials from the @tt{racket-git} credential store when an entry exists for the remote host. - -@section[#:tag "command-form"]{Command form} - -The following command-like forms are supported directly: - -@racketblock[ -(git 'help) -(git 'help 'grep) -(git 'version) -(git 'init) -(git 'clone "https://example/repo.git") -(git 'status) -(git 'add "file.rkt") -(git 'add '-A) -(git 'restore '--staged "file.rkt") -(git 'reset 'HEAD "--" "file.rkt") -(git 'config "user.name" "Name") -(git 'commit "message") -(git 'branch-current) -(git 'branch) -(git 'branch "feature") -(git 'branch-create "rescue" "HEAD") -(git 'switch "feature") -(git 'merge "rescue") -(git 'branch '-d "feature") -(git 'checkout "main") -(git 'checkout '-b "feature") -(git 'tag) -(git 'tag "v0.1") -(git 'tag '-d "v0.1") -(git 'log 10) -(git 'remote) -(git 'remote 'add "origin" "https://example/repo.git") -(git 'remote 'get-url "origin") -(git 'fetch) -(git 'pull) -(git 'push) -(git 'push #:quiet #t) -(git 'push-tag "v0.1") -] - -@section[#:tag "credentials"]{HTTPS credentials} - -Git credentials are stored in @tt{racket-git.ini} in the normal Racket -preferences directory. Tokens are encrypted with AES-GCM. The encryption key is -derived from the store password with PBKDF2-HMAC-SHA256. - -@defproc[(git-credentials-init! [password string?] - [#:unlock-for seconds real? 86400]) void?]{ -Creates the credential store and leaves it unlocked for @racket[seconds].} - -@defproc[(git-credentials-unlock! [password string?] - [#:for seconds real? 86400]) void?]{ -Unlocks the credential store. The temporary unlock state is stored separately in -@tt{racket-git-unlock.ini}, allowing the unlock to survive restarting DrRacket -or starting another Racket process. Both credential INI files use -@racket[#:private? #t] storage from @racketmodname[simple-ini], which restricts -them to mode 0600 on Unix.} - -@defproc[(git-credentials-lock!) void?]{Locks the credential store immediately.} - -@defproc[(git-credentials-unlocked?) boolean?]{Returns whether a non-expired -unlock key is currently available.} - -@defproc[(git-credentials-set! [remote string?] [username string?] [token string?]) void?]{ -Stores an HTTPS username and token. Credentials are keyed by host.} - -@defproc[(git-credentials-ref [remote string?]) (or/c #f pair?)]{ -Returns the username/token pair for @racket[remote], or @racket[#f] when none is -stored. The store must be unlocked when a credential exists.} - -@defproc[(git-credentials-remove! [remote string?]) void?]{Removes credentials -for the host represented by @racket[remote].} diff --git a/tests/basic.rkt b/tests/basic.rkt deleted file mode 100644 index b18b0d7..0000000 --- a/tests/basic.rkt +++ /dev/null @@ -1,189 +0,0 @@ -#lang racket/base - -(require rackunit - racket/file - git) - -(define tmp (make-temporary-file "racket-git-test~a" 'directory)) - -(dynamic-wind - void - (lambda () - (make-directory (build-path tmp "sub")) - (parameterize ([current-directory tmp]) - (git 'init) - (check-true (git-repository?)) - (check-equal? (git-current-branch) "master") - (check-equal? (git 'branch-current) "master") - (check-true (git-clean?)) - - (git 'config "user.name" "Racket Git Test") - (git 'config "user.email" "racket-git-test@example.invalid") - (check-equal? (git-config "user.name") "Racket Git Test") - - (call-with-output-file ".gitignore" - #:exists 'truncate/replace - (lambda (out) (displayln "ignored.txt" out))) - (call-with-output-file "ignored.txt" - #:exists 'truncate/replace - (lambda (out) (displayln "ignored" out))) - (call-with-output-file (build-path "sub" "hello.txt") - #:exists 'truncate/replace - (lambda (out) (displayln "hello" out))) - - (check-equal? (git-status-lines) - '("?? .gitignore" "?? sub/hello.txt")) - - (define status-output (open-output-string)) - (define displayed-status - (parameterize ([current-output-port status-output]) - (dgit 'status))) - (check-equal? displayed-status (git 'status)) - (check-equal? (get-output-string status-output) - "New - .gitignore\nNew - sub/hello.txt\n") - (check-false (regexp-match? #rx"ignored[.]txt" - (get-output-string status-output))) - - (parameterize ([current-directory (build-path tmp "sub")]) - (git 'add "hello.txt")) - (check-equal? (git-status-lines) - '("?? .gitignore" "A sub/hello.txt")) - - (git 'add ".gitignore") - (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) "") - - ;; Grep always returns structured entries. -n, -l, and -c affect only - ;; dgit presentation; -i and -v affect matching. - (define grep-hello (git 'grep "hello")) - (check-equal? grep-hello - (list (git-grep-entry "sub/hello.txt" 1 "hello"))) - (check-equal? (git 'grep '-n "hello") grep-hello) - (check-equal? (git 'grep '-l "hello") grep-hello) - (check-equal? (git 'grep '-c "hello") grep-hello) - (check-equal? (git 'grep '-i "HELLO") grep-hello) - (check-false - (for/or ([entry (in-list (git 'grep '-v "hello"))]) - (and (string=? (git-grep-entry-path entry) "sub/hello.txt") - (string=? (git-grep-entry-line entry) "hello")))) - - (define grep-output (open-output-string)) - (parameterize ([current-output-port grep-output]) - (dgit 'grep '-n "hello")) - (check-equal? (get-output-string grep-output) - "sub/hello.txt:1:hello\n") - (define grep-files-output (open-output-string)) - (parameterize ([current-output-port grep-files-output]) - (dgit 'grep '-l "hello")) - (check-equal? (get-output-string grep-files-output) - "sub/hello.txt\n") - (define grep-count-output (open-output-string)) - (parameterize ([current-output-port grep-count-output]) - (dgit 'grep '-c "hello")) - (check-equal? (get-output-string grep-count-output) - "sub/hello.txt:1\n") - - ;; `restore --staged` removes a path from the index without deleting the - ;; worktree file. Once the path is ignored, it disappears from status. - (call-with-output-file "staged.txt" - #:exists 'truncate/replace - (lambda (out) (displayln "staged" out))) - (git 'add "staged.txt") - (call-with-output-file ".gitignore" - #:exists 'append - (lambda (out) (displayln "staged.txt" out))) - (check-not-false - (member "A staged.txt" (git-status-lines))) - (git 'restore '--staged "staged.txt") - (check-false - (member "?? staged.txt" (git-status-lines))) - (check-true (file-exists? "staged.txt")) - ;; Restore the tracked .gitignore from the index and remove the now - ;; untracked test file, returning to a clean repository. - (git 'restore ".gitignore") - (delete-file "staged.txt") - (check-true (git-clean?)) - - (call-with-output-file (build-path "sub" "hello.txt") - #:exists 'truncate/replace - (lambda (out) (displayln "changed" out))) - (define worktree-diff (git 'diff)) - (check-equal? (git 'grep "hello" 'HEAD) - (list (git-grep-entry "sub/hello.txt" 1 "hello"))) - (check-equal? (git 'grep "changed") - (list (git-grep-entry "sub/hello.txt" 1 "changed"))) - (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)) - - ;; Path reset restores the index from HEAD but keeps the worktree edit. - (git 'reset 'HEAD "--" "sub/hello.txt") - (check-equal? (git 'diff '--cached) "") - (check-true (regexp-match? #rx"[+]changed" (git 'diff))) - (check-not-false - (member " M sub/hello.txt" (git-status-lines))) - (git 'add "sub/hello.txt") - (git 'commit "prepare branches") - - (git 'checkout '-b "work") - (call-with-output-file (build-path "sub" "hello.txt") - #:exists 'truncate/replace - (lambda (out) (displayln "work" out))) - (git 'add) - (git 'commit "work change") - (check-equal? (file->string (build-path "sub" "hello.txt")) "work\n") - - (check-equal? (git 'branch-current) "work") - (git 'switch "master") - (check-equal? (file->string (build-path "sub" "hello.txt")) "changed\n") - (check-equal? (git-current-branch) "master") - (check-not-false (member "work" (git 'branch))) - - ;; Safe checkout must not overwrite an uncommitted tracked change. - (call-with-output-file (build-path "sub" "hello.txt") - #:exists 'truncate/replace - (lambda (out) (displayln "dirty" out))) - (check-exn exn:fail? (lambda () (git 'switch "work"))) - (check-equal? (git-current-branch) "master") - (check-equal? (file->string (build-path "sub" "hello.txt")) "dirty\n") - (call-with-output-file (build-path "sub" "hello.txt") - #:exists 'truncate/replace - (lambda (out) (displayln "changed" out))) - - (git 'branch '-d "work") - (check-false (member "work" (git 'branch))) - - (define tag-id (git 'tag "v0.1")) - (check-equal? (string-length tag-id) 40) - (check-equal? (git 'tag) '("v0.1")) - (git 'checkout "v0.1") - (check-false (git-current-branch)) - (check-false (git 'branch-current)) - (check-exn exn:fail? (lambda () (git 'switch "missing"))) - (git 'switch "master") - (check-equal? (git 'branch-current) "master") - (git 'tag '-d "v0.1") - (check-equal? (git 'tag) '()) - - (check-equal? (length (git 'log 10)) 2))) - (lambda () - (delete-directory/files tmp))) - - -;; Help validates its topic before trying to open the installed documentation. -(check-exn exn:fail? (lambda () (git 'help 'not-a-git-command))) -(check-exn exn:fail:contract? (lambda () (git-help "grep"))) diff --git a/tests/branch-merge.rkt b/tests/branch-merge.rkt deleted file mode 100644 index 9c80f0c..0000000 --- a/tests/branch-merge.rkt +++ /dev/null @@ -1,70 +0,0 @@ -#lang racket/base - -(require rackunit - racket/file - git) - - -(check-equal? (git 'version) "0.2.11") -(check-equal? (git-version) "0.2.11") - -(define tmp (make-temporary-file "racket-git-branch-merge-test~a" 'directory)) - -(define (write-file path text) - (call-with-output-file path - #:exists 'truncate/replace - (lambda (out) (display text out)))) - -(dynamic-wind - void - (lambda () - (parameterize ([current-directory tmp]) - (git 'init) - (git 'config "user.name" "Racket Git Test") - (git 'config "user.email" "racket-git-test@example.invalid") - - (write-file "README.md" "base\n") - (git 'add "README.md") - (define base (git 'commit "base")) - - ;; Reproduce the recovery case: create a commit while HEAD is detached, - ;; give that commit a branch name, switch back, and merge it. - (git 'checkout base) - (check-false (git 'branch-current)) - (write-file "README.md" "base\nrescued\n") - (git 'add "README.md") - (define rescued (git 'commit "detached README change")) - (check-false (git 'branch-current)) - - (check-equal? (git 'branch-create "rescue-readme") "rescue-readme") - (check-not-false (member "rescue-readme" (git 'branch))) - (git 'switch "master") - (check-equal? (git 'branch-current) "master") - (check-equal? (git 'merge "rescue-readme") rescued) - (check-equal? (git-head) rescued) - (check-equal? (file->string "README.md") "base\nrescued\n") - (check-false (git 'merge "rescue-readme")) - (git 'branch '-d "rescue-readme") - (check-false (member "rescue-readme" (git 'branch))) - - ;; Also exercise a real two-parent, conflict-free merge. - (git 'branch-create "feature") - (git 'switch "feature") - (write-file "feature.txt" "feature\n") - (git 'add "feature.txt") - (git 'commit "feature change") - - (git 'switch "master") - (write-file "master.txt" "master\n") - (git 'add "master.txt") - (git 'commit "master change") - (define merge-id (git 'merge "feature")) - (check-equal? (string-length merge-id) 40) - (check-equal? (file->string "feature.txt") "feature\n") - (check-equal? (file->string "master.txt") "master\n") - (check-true (git-clean?)) - (check-equal? (git 'branch-current) "master") - (check-true (>= (length (git 'log 10)) 5)) - (git 'branch '-d "feature"))) - (lambda () - (delete-directory/files tmp))) diff --git a/tests/credentials.rkt b/tests/credentials.rkt deleted file mode 100644 index 233560c..0000000 --- a/tests/credentials.rkt +++ /dev/null @@ -1,30 +0,0 @@ -#lang racket/base - -(require rackunit - "../credentials.rkt") - -;; Never touch the real racket-git preferences from the test suite. -(parameterize ([current-git-credentials-store 'racket-git-test] - [current-git-credentials-unlock-store 'racket-git-test-unlock]) - (with-handlers ([exn:fail? (lambda (_) (void))]) - (git-credentials-lock!)) - - (with-handlers ([exn:fail? (lambda (_) (void))]) - (git-credentials-init! "test-password" #:unlock-for 60)) - - (unless (git-credentials-unlocked?) - (git-credentials-unlock! "test-password" #:for 60)) - - (check-true (git-credentials-unlocked?)) - (git-credentials-set! "https://credentials-test.invalid" - "tester" "secret-token") - (check-equal? - (git-credentials-ref "https://credentials-test.invalid") - '("tester" . "secret-token")) - (check-equal? - (git-credentials-ref "https://credentials-test.invalid/a/b.git") - '("tester" . "secret-token")) - (git-credentials-remove! "https://credentials-test.invalid") - (check-false (git-credentials-ref "https://credentials-test.invalid")) - (git-credentials-lock!) - (check-false (git-credentials-unlocked?))) diff --git a/tests/grep-reader.rkt b/tests/grep-reader.rkt deleted file mode 100644 index 81f4151..0000000 --- a/tests/grep-reader.rkt +++ /dev/null @@ -1,32 +0,0 @@ -#lang racket/base - -(require rackunit - "../main.rkt") - -;; The Racket reader parses '-i as the complex number 0-1i. git-grep treats -;; that value as the Git -i option when it appears in option position. -(check-equal? '-i 0-1i) - -;; Exercise the public argument parser indirectly in a temporary repository. -(require racket/file) - -(define tmp (make-temporary-file "git-command-grep-reader~a" 'directory)) - -(dynamic-wind - void - (lambda () - (parameterize ([current-directory tmp]) - (git 'init) - (call-with-output-file "sample.txt" - #:exists 'truncate/replace - (lambda (out) - (displayln "Todo" out) - (displayln "other" out))) - (git 'add "sample.txt") - (define entries (git 'grep '-i "todo")) - (check-equal? (length entries) 1) - (check-equal? (git-grep-entry-path (car entries)) "sample.txt") - (check-equal? (git-grep-entry-line-number (car entries)) 1) - (check-equal? (git-grep-entry-line (car entries)) "Todo"))) - (lambda () - (delete-directory/files tmp #:must-exist? #f))) diff --git a/tests/remote.rkt b/tests/remote.rkt deleted file mode 100644 index fea19b9..0000000 --- a/tests/remote.rkt +++ /dev/null @@ -1,140 +0,0 @@ -#lang racket/base - -(require rackunit - racket/file - git - libgit2) - -(define tmp (make-temporary-file "racket-git-remote-test~a" 'directory)) -(define origin (build-path tmp "origin.git")) -(define a (build-path tmp "a")) -(define b (build-path tmp "b")) -(define c (build-path tmp "c")) - -(define (temporary-push-refs) - (filter (lambda (name) - (regexp-match? #rx"^refs/remotes/racket-git-push-" name)) - (git_reference_list (git_repository_open (current-directory))))) - -(define (configure!) - (git 'config "user.name" "Racket Git Test") - (git 'config "user.email" "racket-git-test@example.invalid")) - -(dynamic-wind - void - (lambda () - (git-init origin #:bare? #t) - (make-directory a) - - (parameterize ([current-directory a]) - (git 'init) - (configure!) - (call-with-output-file "value.txt" - #:exists 'truncate/replace - (lambda (out) (displayln "one" out))) - (git 'add "value.txt") - (git 'commit "one") - (git 'remote 'add "origin" (path->string origin)) - (check-equal? (git 'remote) '("origin")) - (check-equal? (git 'remote 'get-url "origin") (path->string origin)) - (define push-out (open-output-string)) - (parameterize ([current-output-port push-out]) - (git 'push)) - ;; A successful push must remain safe when the returned credentials, - ;; callbacks and options become eligible for collection. - (collect-garbage) - (collect-garbage) - (collect-garbage) - (define push-text (get-output-string push-out)) - (check-equal? (temporary-push-refs) '()) - (check-true (regexp-match? #rx"\\[git\\] push origin/master" push-text)) - (check-true (regexp-match? #rx"\\[git\\] push origin/master: done" push-text)) - ;; A real push reports transfer progress, but the FFI callback itself only - ;; records state. A normal Racket thread performs the output. - (check-true (regexp-match? #rx"100%" push-text)) - (define quiet-out (open-output-string)) - (parameterize ([current-output-port quiet-out]) - (git 'push #:quiet #t)) - (check-equal? (get-output-string quiet-out) "")) - - (git-clone (path->string origin) b) - (define clone-quiet-out (open-output-string)) - (parameterize ([current-output-port clone-quiet-out]) - (git-clone (path->string origin) c #:quiet #t)) - (check-equal? (get-output-string clone-quiet-out) "") - - (parameterize ([current-directory b]) - (configure!) - (check-equal? (git-current-branch) "master") - (call-with-output-file "value.txt" - #:exists 'truncate/replace - (lambda (out) (displayln "two" out))) - (git 'add "value.txt") - (git 'commit "two") - (git 'push) - (check-equal? (temporary-push-refs) '()) - (git 'tag "v2") - (git 'push-tag "v2") - (check-equal? (temporary-push-refs) '()) - (define push-tag-quiet-out (open-output-string)) - (parameterize ([current-output-port push-tag-quiet-out]) - (git 'push-tag "v2" #:quiet #t)) - (check-equal? (get-output-string push-tag-quiet-out) "")) - - (parameterize ([current-directory a]) - (check-equal? (file->string "value.txt") "one\n") - (check-equal? (string-length (git 'pull)) 40) - (check-equal? (file->string "value.txt") "two\n") - (check-true (git-clean?)) - (git 'fetch) - (check-equal? (git 'tag) '("v2")) - (define fetch-quiet-out (open-output-string)) - (parameterize ([current-output-port fetch-quiet-out]) - (git 'fetch #:quiet #t)) - (check-equal? (get-output-string fetch-quiet-out) "") - (define pull-quiet-out (open-output-string)) - (check-false - (parameterize ([current-output-port pull-quiet-out]) - (git 'pull #:quiet #t))) - (check-equal? (get-output-string pull-quiet-out) "") - - (call-with-output-file "local.txt" - #:exists 'truncate/replace - (lambda (out) (displayln "local" out))) - (git 'add "local.txt") - (git 'commit "local change")) - - (parameterize ([current-directory b]) - (call-with-output-file "remote.txt" - #:exists 'truncate/replace - (lambda (out) (displayln "remote" out))) - (git 'add "remote.txt") - (git 'commit "remote change") - (git 'push)) - - (parameterize ([current-directory a]) - (define before (git-head)) - (check-exn #rx"non-fast-forward" - (lambda () (git 'pull))) - (check-equal? (git-head) before) - (check-true (file-exists? "local.txt")) - (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 deleted file mode 100644 index 27ea9e6..0000000 --- a/tests/stress-commit.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#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)))