From 43516e77157f92fc2864b6da69e158f09b2c530d Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Sun, 9 Aug 2026 14:41:59 +0200 Subject: [PATCH] Initial import --- .gitignore | 5 + README.md | 130 +++++---- credentials.rkt | 222 ++++++++++++++++ info.rkt | 22 ++ main.rkt | 598 ++++++++++++++++++++++++++++++++++++++++++ scribblings/git.scrbl | 166 ++++++++++++ tests/basic.rkt | 73 ++++++ tests/credentials.rkt | 30 +++ tests/remote.rkt | 78 ++++++ 9 files changed, 1257 insertions(+), 67 deletions(-) create mode 100644 .gitignore create mode 100644 credentials.rkt create mode 100644 info.rkt create mode 100644 main.rkt create mode 100644 scribblings/git.scrbl create mode 100644 tests/basic.rkt create mode 100644 tests/credentials.rkt create mode 100644 tests/remote.rkt diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e053672 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +/compiled +/doc +/*.bak +/scribblings/compiled +/tests/compiled diff --git a/README.md b/README.md index 4d1ed0f..78bbfdc 100644 --- a/README.md +++ b/README.md @@ -1,93 +1,89 @@ -# racket-git +# git +A small command-line-like Git module for Racket, implemented directly on top of the `libgit2` package. +```racket +(require git) -## Getting started - -To make it easy for you to get started with GitLab, here's a list of recommended next steps. - -Already a pro? Just edit this README.md and make it your own. Want to make it easy? [Use the template at the bottom](#editing-this-readme)! - -## Add your files - -* [Create](https://docs.gitlab.com/user/project/repository/web_editor/#create-a-file) or [upload](https://docs.gitlab.com/user/project/repository/web_editor/#upload-a-file) files -* [Add files using the command line](https://docs.gitlab.com/topics/git/add_files/#add-files-to-a-git-repository) or push an existing Git repository with the following command: - -``` -cd existing_repo -git remote add origin https://framagit.org/racket/racket-git.git -git branch -M main -git push -uf origin main +(git status) +(git add "main.rkt" "info.rkt") +(git commit "Implement raco support") +(git tag "v0.2") +(git checkout "main") ``` -## Integrate with your tools +The same operations are available as normal procedures such as `git-status`, `git-add`, `git-commit`, `git-tag`, and `git-checkout`. -* [Set up project integrations](https://framagit.org/racket/racket-git/-/settings/integrations) +## HTTPS credentials -## Collaborate with your team +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. -* [Invite team members and collaborators](https://docs.gitlab.com/user/project/members/) -* [Create a new merge request](https://docs.gitlab.com/user/project/merge_requests/creating_merge_requests/) -* [Automatically close issues from merge requests](https://docs.gitlab.com/user/project/issues/managing_issues/#closing-issues-automatically) -* [Enable merge request approvals](https://docs.gitlab.com/user/project/merge_requests/approvals/) -* [Set auto-merge](https://docs.gitlab.com/user/project/merge_requests/auto_merge/) +Create the credential store once: -## Test and Deploy +```racket +(git credentials init "store password") +``` -Use the built-in continuous integration in GitLab. +Store a token for a Git host: -* [Get started with GitLab CI/CD](https://docs.gitlab.com/ci/quick_start/) -* [Analyze your code for known vulnerabilities with Static Application Security Testing (SAST)](https://docs.gitlab.com/user/application_security/sast/) -* [Deploy to Kubernetes, Amazon EC2, or Amazon ECS using Auto Deploy](https://docs.gitlab.com/topics/autodevops/requirements/) -* [Use pull-based deployments for improved Kubernetes management](https://docs.gitlab.com/user/clusters/agent/) -* [Set up protected environments](https://docs.gitlab.com/ci/environments/protected_environments/) +```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. -# Editing this README +The store is unlocked for one day by default: -When you're ready to make this README your own, just edit this file and use the handy template below (or feel free to structure it however you want - this is just a starting point!). Thanks to [makeareadme.com](https://www.makeareadme.com/) for this template. +```racket +(git credentials unlock "store password") +``` -## Suggestions for a good README +or for an explicit number of seconds: -Every project is different, so consider which of these sections apply to yours. The sections used in the template are suggestions for most open source projects. Also keep in mind that while a README can be too long and detailed, too long is better than too short. If you think your README is too long, consider utilizing another form of documentation rather than cutting out information. +```racket +(git credentials unlock "store password" (* 8 60 60)) +``` -## Name -Choose a self-explaining name for your project. +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. -## Description -Let people know what your project can do specifically. Provide context and add a link to any reference visitors might be unfamiliar with. A list of Features or a Background subsection can also be added here. If there are alternatives to your project, this is a good place to list differentiating factors. +Lock immediately with: -## Badges -On some READMEs, you may see small images that convey metadata, such as whether or not all the tests are passing for the project. You can use Shields to add some to your README. Many services also have instructions for adding a badge. +```racket +(git credentials lock) +``` -## Visuals -Depending on what you are making, it can be a good idea to include screenshots or even a video (you'll frequently see GIFs rather than actual videos). Tools like ttygif can help, but check out Asciinema for a more sophisticated method. +After credentials have been stored and the store is unlocked, normal remote +operations use them automatically: -## Installation -Within a particular ecosystem, there may be a common way of installing things, such as using Yarn, NuGet, or Homebrew. However, consider the possibility that whoever is reading your README is a novice and would like more guidance. Listing specific steps helps remove ambiguity and gets people to using your project as quickly as possible. If it only runs in a specific context like a particular programming language version or operating system or has dependencies that have to be installed manually, also add a Requirements subsection. +```racket +(git fetch) +(git pull) +(git push) +``` -## Usage -Use examples liberally, and show the expected output if you can. It's helpful to have inline the smallest example of usage that you can demonstrate, while providing links to more sophisticated examples if they are too long to reasonably include in the README. +## Supported Git operations -## Support -Tell people where they can go to for help. It can be any combination of an issue tracker, a chat room, an email address, etc. +Version 0.2 supports repository discovery, init, clone, status, add, config, +commit, branch, checkout, lightweight tags, log, remotes, fetch, +fast-forward-only pull, push, tag push, and HTTPS username/token credentials. -## Roadmap -If you have ideas for releases in the future, it is a good idea to list them in the README. +SSH credentials, merge/rebase pull, annotated tags, and submodules are not yet +part of this module. -## Contributing -State if you are open to contributions and what your requirements are for accepting them. +Install from the package directory with: -For people who want to make changes to your project, it's helpful to have some documentation on how to get started. Perhaps there is a script that they should run or some environment variables that they need to set. Make these steps explicit. These instructions could also be useful to your future self. - -You can also document commands to lint the code or run tests. These steps help to ensure high code quality and reduce the likelihood that the changes inadvertently break something. Having instructions for running tests is especially helpful if it requires external setup, such as starting a Selenium server for testing in a browser. - -## Authors and acknowledgment -Show your appreciation to those who have contributed to the project. - -## License -For open source projects, say how it is licensed. - -## Project status -If you have run out of energy or time for your project, put a note at the top of the README saying that development has slowed down or stopped completely. Someone may choose to fork your project or volunteer to step in as a maintainer or owner, allowing your project to keep going. You can also make an explicit request for maintainers. +```sh +raco pkg install . +``` diff --git a/credentials.rkt b/credentials.rkt new file mode 100644 index 0000000..c19df6a --- /dev/null +++ b/credentials.rkt @@ -0,0 +1,222 @@ +#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-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-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 new file mode 100644 index 0000000..11f6ab4 --- /dev/null +++ b/info.rkt @@ -0,0 +1,22 @@ +#lang info + +(define collection "git") +(define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2") +(define version "0.2.1") +(define pkg-authors '("Hans Dijkema")) +(define license 'MIT) + +(define deps + '("base" + "libgit2" + ("simple-ini" #:version "0.3.3") + "crypto-lib" + "net-lib")) + +(define build-deps + '("rackunit-lib" + "scribble-lib" + "racket-doc")) + +(define scribblings + '(("scribblings/git.scrbl" () ("Git")))) diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..c0a5a36 --- /dev/null +++ b/main.rkt @@ -0,0 +1,598 @@ +#lang racket/base + +(require ffi/unsafe + racket/list + racket/path + racket/string + "credentials.rkt" + (except-in libgit2 git_remote_push) + (only-in libgit2/private/base + define-libgit2 + _git_error_code/check)) + +(provide git + git-repository? + git-root + git-init + git-clone + (struct-out git-status-entry) + git-status + git-status-lines + git-clean? + git-add + git-config + git-config-get + git-config-set + git-commit + git-head + git-current-branch + git-branches + git-branch + git-branch-delete + git-checkout + git-checkout-new + git-tags + git-tag + git-tag-delete + (struct-out git-log-entry) + git-log + git-log-lines + git-remotes + git-remote-add + git-remote-url + git-fetch + git-pull + git-push + git-push-tag + git-credentials-init! + git-credentials-unlock! + git-credentials-lock! + git-credentials-unlocked? + git-credentials-unlock-expires + git-credentials-set! + git-credentials-ref + git-credentials-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/") + +(define GIT-CREDTYPE-USERPASS-PLAINTEXT #x0001) +(define GIT-CREDTYPE-USERNAME #x0020) +(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])])) + +(define (set-credential-callback! callbacks) + (set-git_remote_callbacks-credentials! callbacks git-credential-callback) + callbacks) + +(define (make-fetch-options) + (define options + (cast (malloc _git_fetch_opts 'atomic) _pointer _git_fetch_opts-pointer)) + (git_fetch_options_init options GIT_FETCH_OPTS_VERSION) + (set-credential-callback! (git_fetch_opts-callbacks options)) + options) + +(define (make-push-options) + (define options + (cast (malloc _git_push_opts 'atomic) _pointer _git_push_opts-pointer)) + (git_push_options_init options GIT_PUSH_OPTS_VERSION) + (set-credential-callback! (git_push_opts-callbacks options)) + options) + +(define (make-clone-options) + (define options + (cast (malloc _git_clone_opts 'atomic) _pointer _git_clone_opts-pointer)) + (git_clone_options_init options GIT_CLONE_OPTS_VERSION) + (set-credential-callback! + (git_fetch_opts-callbacks (git_clone_opts-fetch_opts options))) + options) + +(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 + (case-lambda + [(url) + (git-clone url (default-clone-directory url))] + [(url path) + (git_clone url + (path->string (if (path? path) path (string->path path))) + (make-clone-options)) + (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 path) "/")) + +(define (relative-pathspec workdir path) + (define p0 (if (path? path) path (string->path path))) + ;; A relative path supplied by the caller is relative to the caller's + ;; current directory, not automatically to the repository root. + (define p (path->complete-path p0 (current-directory))) + (define rel (find-relative-path workdir p)) + (define s (git-path-string rel)) + (when (or (string=? s "..") + (string-prefix? s "../")) + (error 'git-add "path is outside the repository: ~a" path)) + s) + +(define (index-accept _path _matched-pathspec _payload) + 0) + +(define (git-add . paths) + (define repo (open-repository)) + (define workdir (string->path (git_repository_workdir repo))) + (define index (git_repository_index repo)) + (define pathspecs + (make-git_strarray + (for/list ([path (in-list paths)]) + (relative-pathspec workdir path)))) + ;; update-all stages changes and removals of already tracked files; + ;; add-all adds new files and updates existing files while respecting ignores. + (git_index_update_all index pathspecs index-accept #"") + (git_index_add_all index pathspecs 'GIT_INDEX_ADD_DEFAULT index-accept #"") + (git_index_write index) + (void)) + +(define (git-config-get key) + (define repo (open-repository)) + (define config (git_repository_config repo)) + ;; git_config_get_string is incorrectly declared as an allocating wrapper + ;; in the current Racket libgit2 package. The entry API has the correct + ;; ownership model and works on normal repository config objects. + (define entry (git_config_get_entry config key)) + (git_config_entry-value entry)) + +(define (git-config-set key value) + (define repo (open-repository)) + (define config (git_repository_config repo)) + (git_config_set_string config key value) + value) + +(define git-config + (case-lambda + [(key) (git-config-get key)] + [(key value) (git-config-set key value)])) + +(define (head-commit repo) + (cond + [(git_repository_is_empty repo) #f] + [(git_repository_head_unborn repo) #f] + [else + (define head (git_repository_head repo)) + (git_commit_lookup repo (git_reference_target head))])) + +(define (git-head) + (define repo (open-repository)) + (define commit (head-commit repo)) + (and commit (git_oid_fmt (git_commit_id commit)))) + +(define (git-commit message) + (define repo (open-repository)) + (define index (git_repository_index repo)) + (when (git_index_has_conflicts index) + (error 'git-commit "the index contains unresolved conflicts")) + + (define tree-id (blank-oid)) + (git_index_write_tree tree-id index) + (define tree (git_tree_lookup repo tree-id)) + (define parent (head-commit repo)) + + (cond + [(and (not parent) (zero? (git_index_entrycount index))) + (error 'git-commit "nothing staged to commit")] + [(and parent (git_oid_equal tree-id (git_commit_tree_id parent))) + (error 'git-commit "nothing staged to commit")]) + + (define signature (git_signature_default repo)) + (define commit-id (blank-oid)) + (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)) + (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 (build-path "sub" "hello.txt")) "work\n") + + (git checkout "master") + (check-equal? (file->string (build-path "sub" "hello.txt")) "hello\n") + (check-equal? (git-current-branch) "master") + (check-not-false (member "work" (git branch))) + + (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)) + (git checkout "master") + (git tag -d "v0.1") + (check-equal? (git tag) '()) + + (check-equal? (length (git log 10)) 1))) + (lambda () + (delete-directory/files tmp))) diff --git a/tests/credentials.rkt b/tests/credentials.rkt new file mode 100644 index 0000000..233560c --- /dev/null +++ b/tests/credentials.rkt @@ -0,0 +1,30 @@ +#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/remote.rkt b/tests/remote.rkt new file mode 100644 index 0000000..9d8d3d1 --- /dev/null +++ b/tests/remote.rkt @@ -0,0 +1,78 @@ +#lang racket/base + +(require rackunit + racket/file + git) + +(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 (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)) + (git push)) + + (git-clone (path->string origin) b) + (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) + (git tag "v2") + (git push-tag "v2")) + + (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")) + + (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)))