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

Initial import

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-09 14:41:59 +02:00
parent ad5200d58d
commit 43516e7715
9 changed files with 1257 additions and 67 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+5
View File
@@ -0,0 +1,5 @@
/compiled
/doc
/*.bak
/scribblings/compiled
/tests/compiled
README.md
+63 -67
View File
@@ -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 (git status)
(git add "main.rkt" "info.rkt")
To make it easy for you to get started with GitLab, here's a list of recommended next steps. (git commit "Implement raco support")
(git tag "v0.2")
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)! (git checkout "main")
## 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
``` ```
## 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 the credential store once:
* [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/)
## 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/) ```racket
* [Analyze your code for known vulnerabilities with Static Application Security Testing (SAST)](https://docs.gitlab.com/user/application_security/sast/) (git credentials set
* [Deploy to Kubernetes, Amazon EC2, or Amazon ECS using Auto Deploy](https://docs.gitlab.com/topics/autodevops/requirements/) "https://git.dijkewijk.nl"
* [Use pull-based deployments for improved Kubernetes management](https://docs.gitlab.com/user/clusters/agent/) "hans"
* [Set up protected environments](https://docs.gitlab.com/ci/environments/protected_environments/) 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 The temporary unlock state is stored in `racket-git-unlock.ini` in Racket's
Choose a self-explaining name for your project. 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 Lock immediately with:
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.
## Badges ```racket
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. (git credentials lock)
```
## Visuals After credentials have been stored and the store is unlocked, normal remote
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. operations use them automatically:
## Installation ```racket
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. (git fetch)
(git pull)
(git push)
```
## Usage ## Supported Git operations
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.
## Support Version 0.2 supports repository discovery, init, clone, status, add, config,
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. commit, branch, checkout, lightweight tags, log, remotes, fetch,
fast-forward-only pull, push, tag push, and HTTPS username/token credentials.
## Roadmap SSH credentials, merge/rebase pull, annotated tags, and submodules are not yet
If you have ideas for releases in the future, it is a good idea to list them in the README. part of this module.
## Contributing Install from the package directory with:
State if you are open to contributions and what your requirements are for accepting them.
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. ```sh
raco pkg install .
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.
credentials.rkt
+222
View File
@@ -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))
info.rkt
+22
View File
@@ -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"))))
main.rkt
+598
View File
@@ -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)
(string<? (git-status-entry-path a)
(git-status-entry-path b)))))
(define (git-status-lines [entries (git-status)])
(for/list ([entry (in-list entries)])
(format "~a ~a"
(git-status-entry-code entry)
(git-status-entry-path entry))))
(define (git-clean?)
(null? (git-status)))
(define (git-path-string path)
(regexp-replace* #rx"\\\\" (path->string 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 string<?))
(define (create-branch name)
(define repo (open-repository))
(define commit (head-commit repo))
(unless commit
(error 'git-branch "cannot create a branch before the first commit"))
(git_branch_create repo name commit #f)
name)
(define git-branch
(case-lambda
[() (git-branches)]
[(name) (create-branch name)]))
(define (git-branch-delete name)
(define repo (open-repository))
(define ref (git_branch_lookup repo name 'GIT_BRANCH_LOCAL))
(git_branch_delete ref)
(void))
(define (git-checkout name)
(define repo (open-repository))
(cond
[(member name (git-branches))
(define refname (string-append branch-prefix name))
(define object (git_revparse_single repo (string-append refname "^{commit}")))
;; Checkout first: with default safe checkout, a dirty worktree aborts
;; before HEAD is changed.
(git_checkout_tree repo object #f)
(git_repository_set_head repo refname)]
[else
(define object (git_revparse_single repo (string-append name "^{commit}")))
(git_checkout_tree repo object #f)
(git_repository_set_head_detached repo (git_object_id object))])
(git-head))
(define (git-checkout-new name)
(git-branch name)
(git-checkout name))
(define (git-tags)
(define tags null)
(git_tag_foreach
(open-repository)
(lambda (name _oid _payload)
(set! tags
(cons (if (string-prefix? name tag-prefix)
(substring name (string-length tag-prefix))
name)
tags))
0)
#"")
(sort tags string<?))
(define (create-tag name)
(define repo (open-repository))
(unless (head-commit repo)
(error 'git-tag "cannot tag a repository without commits"))
(define target (git_revparse_single repo "HEAD^{commit}"))
(define tag-id (blank-oid))
(git_tag_create_lightweight tag-id repo name target #f)
(git_oid_fmt tag-id))
(define git-tag
(case-lambda
[() (git-tags)]
[(name) (create-tag name)]))
(define (git-tag-delete name)
(git_tag_delete (open-repository) name)
(void))
(define (git-log [max-count 20])
(unless (exact-nonnegative-integer? max-count)
(raise-argument-error 'git-log "exact-nonnegative-integer?" max-count))
(define repo (open-repository))
(cond
[(not (head-commit repo)) null]
[else
(define walk (git_revwalk_new repo))
(git_revwalk_sorting walk '(GIT_SORT_TOPOLOGICAL GIT_SORT_TIME))
(git_revwalk_push_head walk)
(let loop ([left max-count] [result null])
(cond
[(zero? left) (reverse result)]
[else
(define oid (git_revwalk_next walk))
(if oid
(let ([commit (git_commit_lookup repo oid)])
(loop (sub1 left)
(cons (git-log-entry (git_oid_fmt oid)
(or (git_commit_summary commit) "")
(git_commit_time commit))
result)))
(reverse result))]))]))
(define (git-log-lines [entries (git-log)])
(for/list ([entry (in-list entries)])
(format "~a ~a"
(substring (git-log-entry-id entry) 0 7)
(git-log-entry-summary entry))))
(define (git-remotes)
;; git_remote_list is affected by the same git_strarray wrapper problem as
;; git_tag_list in the current Racket bindings. Remote URLs are stored in
;; repository config, so enumerate those entries instead.
(define repo (open-repository))
(define config (git_repository_config repo))
(define remotes null)
(git_config_foreach
config
(lambda (entry _payload)
(define key (git_config_entry-name entry))
(define m (regexp-match #rx"^remote[.](.+)[.]url$" key))
(when m
(set! remotes (cons (cadr m) remotes)))
0)
#"")
(sort (remove-duplicates remotes) string<?))
(define (git-remote-add name url)
(git_remote_create (open-repository) name url)
name)
(define (git-remote-url [name "origin"])
(define remote (git_remote_lookup (open-repository) name))
(git_remote_url remote))
(define (git-fetch [name "origin"])
(define repo (open-repository))
(define remote (git_remote_lookup repo name))
(git_remote_fetch remote #f (make-fetch-options) (format "fetch ~a" name))
(void))
(define (git-pull [remote-name "origin"])
(define branch (git-current-branch))
(unless branch
(error 'git-pull "pull requires an attached local branch"))
(git-fetch 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) #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 #f)
(git_reference_set_target
local-ref remote-id (format "pull: fast-forward from ~a" remote-name))
(git_oid_fmt remote-id)]
[else
(error 'git-pull
"non-fast-forward pull is not supported; merge or rebase explicitly")]))
(define (push-refspec remote-name refspec)
(define repo (open-repository))
(define remote (git_remote_lookup repo remote-name))
(define options (make-push-options))
(define strings
(cast (list refspec) (_list i _string interior) _gcpointer))
(define refspecs (make-git_strarray/raw strings 1))
(git_remote_push/raw remote refspecs options)
;; Keep the C string-pointer array alive through the foreign call.
(void strings)
(void))
(define git-push
(case-lambda
[()
(define branch (git-current-branch))
(unless branch
(error 'git-push "push requires an attached local branch"))
(git-push "origin" branch)]
[(remote-name)
(define branch (git-current-branch))
(unless branch
(error 'git-push "push requires an attached local branch"))
(git-push remote-name branch)]
[(remote-name branch)
(push-refspec
remote-name
(format "refs/heads/~a:refs/heads/~a" branch branch))]))
(define git-push-tag
(case-lambda
[(tag) (git-push-tag tag "origin")]
[(tag remote-name)
(push-refspec
remote-name
(format "refs/tags/~a:refs/tags/~a" tag tag))]))
(define-syntax git
(syntax-rules (init clone status add config commit branch -d checkout -b
tag log remote get-url fetch pull push push-tag
credentials init unlock lock set remove unlocked?)
[(_ init args ...) (git-init args ...)]
[(_ clone args ...) (git-clone args ...)]
[(_ status) (git-status)]
[(_ add paths ...) (git-add paths ...)]
[(_ config args ...) (git-config args ...)]
[(_ commit message) (git-commit message)]
[(_ branch -d name) (git-branch-delete name)]
[(_ branch) (git-branch)]
[(_ branch name) (git-branch name)]
[(_ checkout -b name) (git-checkout-new name)]
[(_ checkout name) (git-checkout name)]
[(_ tag -d name) (git-tag-delete name)]
[(_ tag) (git-tag)]
[(_ tag name) (git-tag name)]
[(_ log) (git-log)]
[(_ log count) (git-log count)]
[(_ remote) (git-remotes)]
[(_ remote add name url) (git-remote-add name url)]
[(_ remote get-url name) (git-remote-url name)]
[(_ fetch) (git-fetch)]
[(_ fetch remote-name) (git-fetch remote-name)]
[(_ pull) (git-pull)]
[(_ pull remote-name) (git-pull remote-name)]
[(_ push) (git-push)]
[(_ push remote-name) (git-push remote-name)]
[(_ push remote-name branch) (git-push remote-name branch)]
[(_ push-tag tag-name) (git-push-tag tag-name)]
[(_ push-tag tag-name remote-name) (git-push-tag tag-name remote-name)]
[(_ credentials init password) (git-credentials-init! password)]
[(_ credentials unlock password) (git-credentials-unlock! password)]
[(_ credentials unlock password seconds)
(git-credentials-unlock! password #:for seconds)]
[(_ credentials lock) (git-credentials-lock!)]
[(_ credentials unlocked?) (git-credentials-unlocked?)]
[(_ credentials set remote username token)
(git-credentials-set! remote username token)]
[(_ credentials remove remote) (git-credentials-remove! remote)]))
scribblings/git.scrbl
+166
View File
@@ -0,0 +1,166 @@
#lang scribble/manual
@(require (for-label racket/base git))
@title{git}
@author{Hans Dijkema}
@defmodule[git]
The @racketmodname[git] module provides a small command-line-like Git interface implemented on top of the @tt{libgit2} package. It does not invoke the @tt{git} executable.
The short form is intended for build scripts and interactive use:
@racketblock[
(require git)
(git status)
(git add "main.rkt" "info.rkt")
(git commit "Implement raco support")
(git tag "v0.1")
(git checkout "main")
]
@defform[(git command argument ...)]{
The @racket[git] form is syntax sugar for the corresponding procedures. For example, @racket[(git status)] calls @racket[git-status], and @racket[(git commit "message")] calls @racket[git-commit].
}
@section{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?]) path?]
[(git-clone [url string?] [path path-string?]) path?])]{Clones @racket[url]. If @racket[path] is omitted, a directory name is derived from the URL.}
@section{Status and index}
@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.}
@defproc[(git-add [path path-string?] ...) void?]{Stages the given paths. With no paths, stages the whole repository, including tracked removals.}
@section{Configuration and commits}
@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.}
@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.}
@section{Branches, checkout, and tags}
@defproc[(git-current-branch) (or/c string? #f)]{Returns the current local branch name, or @racket[#f] for detached HEAD.}
@defproc*[([(git-branch) (listof string?)]
[(git-branch [name string?]) string?])]{Lists local branches, or creates @racket[name] at HEAD.}
@defproc[(git-branch-delete [name string?]) void?]{Deletes a local branch.}
@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.}
@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.}
@section{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{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"]) void?]{Fetches the configured refspecs from a remote.}
@defproc[(git-pull [remote string? "origin"]) (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) void?]
[(git-push [remote string?]) void?]
[(git-push [remote string?] [branch string?]) void?])]{Pushes a branch to a branch with the same name. With no arguments, the current branch is pushed to @tt{origin}; with only @racket[remote], the current branch is pushed there.}
@defproc[(git-push-tag [tag string?] [remote string? "origin"]) void?]{Pushes one tag.}
Remote HTTPS operations automatically use credentials from the @tt{racket-git} credential store when an entry exists for the remote host.
@section{Command form}
The following command-like forms are supported directly:
@racketblock[
(git init)
(git clone "https://example/repo.git")
(git status)
(git add "file.rkt")
(git config "user.name" "Name")
(git commit "message")
(git branch)
(git branch "feature")
(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-tag "v0.1")
]
@section{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].}
tests/basic.rkt
+73
View File
@@ -0,0 +1,73 @@
#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-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"))
(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?))
(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")
(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)))
tests/credentials.rkt
+30
View File
@@ -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?)))
tests/remote.rkt
+78
View File
@@ -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)))