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

Simplifying.

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-09 14:42:54 +02:00
parent 43516e7715
commit 4689c56e4d
6 changed files with 201 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README.md
+19 -13
View File
@@ -5,13 +5,19 @@ A small command-line-like Git module for Racket, implemented directly on top of
```racket ```racket
(require git) (require git)
(git status) (git 'status)
(git add "main.rkt" "info.rkt") (git 'add "main.rkt" "info.rkt")
(git commit "Implement raco support") (git 'commit "Implement raco support")
(git tag "v0.2") (git 'tag "v0.2")
(git checkout "main") (git 'checkout "main")
;; Display-oriented variant:
(dgit 'status)
``` ```
`git` is an ordinary procedure; command names are symbols. `dgit` performs the
same operation, displays a compact human-readable result, and returns that result.
The same operations are available as normal procedures such as `git-status`, `git-add`, `git-commit`, `git-tag`, and `git-checkout`. The same operations are available as normal procedures such as `git-status`, `git-add`, `git-commit`, `git-tag`, and `git-checkout`.
## HTTPS credentials ## HTTPS credentials
@@ -24,13 +30,13 @@ PBKDF2-HMAC-SHA256.
Create the credential store once: Create the credential store once:
```racket ```racket
(git credentials init "store password") (git 'credentials 'init "store password")
``` ```
Store a token for a Git host: Store a token for a Git host:
```racket ```racket
(git credentials set (git 'credentials 'set
"https://git.dijkewijk.nl" "https://git.dijkewijk.nl"
"hans" "hans"
token) token)
@@ -42,13 +48,13 @@ repositories on that host.
The store is unlocked for one day by default: The store is unlocked for one day by default:
```racket ```racket
(git credentials unlock "store password") (git 'credentials 'unlock "store password")
``` ```
or for an explicit number of seconds: or for an explicit number of seconds:
```racket ```racket
(git credentials unlock "store password" (* 8 60 60)) (git 'credentials 'unlock "store password" (* 8 60 60))
``` ```
The temporary unlock state is stored in `racket-git-unlock.ini` in Racket's The temporary unlock state is stored in `racket-git-unlock.ini` in Racket's
@@ -61,16 +67,16 @@ so `racket-git-unlock.ini` must be treated as sensitive during that period.
Lock immediately with: Lock immediately with:
```racket ```racket
(git credentials lock) (git 'credentials 'lock)
``` ```
After credentials have been stored and the store is unlocked, normal remote After credentials have been stored and the store is unlocked, normal remote
operations use them automatically: operations use them automatically:
```racket ```racket
(git fetch) (git 'fetch)
(git pull) (git 'pull)
(git push) (git 'push)
``` ```
## Supported Git operations ## Supported Git operations
info.rkt
+1 -1
View File
@@ -2,7 +2,7 @@
(define collection "git") (define collection "git")
(define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2") (define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2")
(define version "0.2.1") (define version "0.2.2")
(define pkg-authors '("Hans Dijkema")) (define pkg-authors '("Hans Dijkema"))
(define license 'MIT) (define license 'MIT)
main.rkt
+92 -41
View File
@@ -2,6 +2,7 @@
(require ffi/unsafe (require ffi/unsafe
racket/list racket/list
racket/match
racket/path racket/path
racket/string racket/string
"credentials.rkt" "credentials.rkt"
@@ -11,6 +12,7 @@
_git_error_code/check)) _git_error_code/check))
(provide git (provide git
dgit
git-repository? git-repository?
git-root git-root
git-init git-init
@@ -555,44 +557,93 @@
remote-name remote-name
(format "refs/tags/~a:refs/tags/~a" tag tag))])) (format "refs/tags/~a:refs/tags/~a" tag tag))]))
(define-syntax git (define (git command . args)
(syntax-rules (init clone status add config commit branch -d checkout -b (unless (symbol? command)
tag log remote get-url fetch pull push push-tag (raise-argument-error 'git "symbol?" command))
credentials init unlock lock set remove unlocked?) (case command
[(_ init args ...) (git-init args ...)] [(init) (apply git-init args)]
[(_ clone args ...) (git-clone args ...)] [(clone) (apply git-clone args)]
[(_ status) (git-status)] [(status) (apply git-status args)]
[(_ add paths ...) (git-add paths ...)] [(add) (apply git-add args)]
[(_ config args ...) (git-config args ...)] [(config) (apply git-config args)]
[(_ commit message) (git-commit message)] [(commit) (apply git-commit args)]
[(_ branch -d name) (git-branch-delete name)] [(branch)
[(_ branch) (git-branch)] (match args
[(_ branch name) (git-branch name)] [(list '-d name) (git-branch-delete name)]
[(_ checkout -b name) (git-checkout-new name)] [_ (apply git-branch args)])]
[(_ checkout name) (git-checkout name)] [(checkout)
[(_ tag -d name) (git-tag-delete name)] (match args
[(_ tag) (git-tag)] [(list '-b name) (git-checkout-new name)]
[(_ tag name) (git-tag name)] [_ (apply git-checkout args)])]
[(_ log) (git-log)] [(tag)
[(_ log count) (git-log count)] (match args
[(_ remote) (git-remotes)] [(list '-d name) (git-tag-delete name)]
[(_ remote add name url) (git-remote-add name url)] [_ (apply git-tag args)])]
[(_ remote get-url name) (git-remote-url name)] [(log) (apply git-log args)]
[(_ fetch) (git-fetch)] [(remote)
[(_ fetch remote-name) (git-fetch remote-name)] (match args
[(_ pull) (git-pull)] ['() (git-remotes)]
[(_ pull remote-name) (git-pull remote-name)] [(list 'add name url) (git-remote-add name url)]
[(_ push) (git-push)] [(list 'get-url name) (git-remote-url name)]
[(_ push remote-name) (git-push remote-name)] [_ (error 'git "invalid remote arguments: ~e" args)])]
[(_ push remote-name branch) (git-push remote-name branch)] [(fetch) (apply git-fetch args)]
[(_ push-tag tag-name) (git-push-tag tag-name)] [(pull) (apply git-pull args)]
[(_ push-tag tag-name remote-name) (git-push-tag tag-name remote-name)] [(push) (apply git-push args)]
[(_ credentials init password) (git-credentials-init! password)] [(push-tag) (apply git-push-tag args)]
[(_ credentials unlock password) (git-credentials-unlock! password)] [(credentials)
[(_ credentials unlock password seconds) (match args
(git-credentials-unlock! password #:for seconds)] [(list 'init password) (git-credentials-init! password)]
[(_ credentials lock) (git-credentials-lock!)] [(list 'unlock password) (git-credentials-unlock! password)]
[(_ credentials unlocked?) (git-credentials-unlocked?)] [(list 'unlock password seconds)
[(_ credentials set remote username token) (git-credentials-unlock! password #:for seconds)]
(git-credentials-set! remote username token)] [(list 'lock) (git-credentials-lock!)]
[(_ credentials remove remote) (git-credentials-remove! remote)])) [(list 'unlocked?) (git-credentials-unlocked?)]
[(list 'set remote username token)
(git-credentials-set! remote username token)]
[(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 '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 (dgit command . args)
(define result (apply git command args))
(display-git-result command result)
result)
scribblings/git.scrbl
+37 -29
View File
@@ -14,17 +14,25 @@ The short form is intended for build scripts and interactive use:
@racketblock[ @racketblock[
(require git) (require git)
(git status) (git 'status)
(git add "main.rkt" "info.rkt") (git 'add "main.rkt" "info.rkt")
(git commit "Implement raco support") (git 'commit "Implement raco support")
(git tag "v0.1") (git 'tag "v0.1")
(git checkout "main") (git 'checkout "main")
] ]
@defform[(git command argument ...)]{ @defproc[(git [command symbol?] [argument any/c] ...) any/c]{
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]. Dispatches @racket[command] to the corresponding Git procedure. For example, @racket[(git 'status)] calls @racket[git-status], and @racket[(git 'commit "message")] calls @racket[git-commit]. Command names are ordinary symbols, so @racket[git] can safely be used inside other macros and DSLs.
} }
@defproc[(dgit [command symbol?] [argument any/c] ...) any/c]{
Calls @racket[git], displays its result in a compact human-readable form, and returns the original result. Status entries are displayed with labels such as @tt{Modified}, @tt{New}, @tt{Deleted}, and @tt{Renamed}. Ignored files remain omitted, just as with @racket[git-status].
}
@racketblock[
(dgit 'status)
]
@section{Repository} @section{Repository}
@defproc[(git-repository? [path path-string? (current-directory)]) boolean?]{Returns whether @racket[path] is inside a Git repository.} @defproc[(git-repository? [path path-string? (current-directory)]) boolean?]{Returns whether @racket[path] is inside a Git repository.}
@@ -108,28 +116,28 @@ Remote HTTPS operations automatically use credentials from the @tt{racket-git} c
The following command-like forms are supported directly: The following command-like forms are supported directly:
@racketblock[ @racketblock[
(git init) (git 'init)
(git clone "https://example/repo.git") (git 'clone "https://example/repo.git")
(git status) (git 'status)
(git add "file.rkt") (git 'add "file.rkt")
(git config "user.name" "Name") (git 'config "user.name" "Name")
(git commit "message") (git 'commit "message")
(git branch) (git 'branch)
(git branch "feature") (git 'branch "feature")
(git branch -d "feature") (git 'branch '-d "feature")
(git checkout "main") (git 'checkout "main")
(git checkout -b "feature") (git 'checkout '-b "feature")
(git tag) (git 'tag)
(git tag "v0.1") (git 'tag "v0.1")
(git tag -d "v0.1") (git 'tag '-d "v0.1")
(git log 10) (git 'log 10)
(git remote) (git 'remote)
(git remote add "origin" "https://example/repo.git") (git 'remote 'add "origin" "https://example/repo.git")
(git remote get-url "origin") (git 'remote 'get-url "origin")
(git fetch) (git 'fetch)
(git pull) (git 'pull)
(git push) (git 'push)
(git push-tag "v0.1") (git 'push-tag "v0.1")
] ]
@section{HTTPS credentials} @section{HTTPS credentials}
tests/basic.rkt
+29 -19
View File
@@ -11,13 +11,13 @@
(lambda () (lambda ()
(make-directory (build-path tmp "sub")) (make-directory (build-path tmp "sub"))
(parameterize ([current-directory tmp]) (parameterize ([current-directory tmp])
(git init) (git 'init)
(check-true (git-repository?)) (check-true (git-repository?))
(check-equal? (git-current-branch) "master") (check-equal? (git-current-branch) "master")
(check-true (git-clean?)) (check-true (git-clean?))
(git config "user.name" "Racket Git Test") (git 'config "user.name" "Racket Git Test")
(git config "user.email" "racket-git-test@example.invalid") (git 'config "user.email" "racket-git-test@example.invalid")
(check-equal? (git-config "user.name") "Racket Git Test") (check-equal? (git-config "user.name") "Racket Git Test")
(call-with-output-file ".gitignore" (call-with-output-file ".gitignore"
@@ -33,41 +33,51 @@
(check-equal? (git-status-lines) (check-equal? (git-status-lines)
'("?? .gitignore" "?? sub/hello.txt")) '("?? .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")]) (parameterize ([current-directory (build-path tmp "sub")])
(git add "hello.txt")) (git 'add "hello.txt"))
(check-equal? (git-status-lines) (check-equal? (git-status-lines)
'("?? .gitignore" "A sub/hello.txt")) '("?? .gitignore" "A sub/hello.txt"))
(git add ".gitignore") (git 'add ".gitignore")
(define first (git-commit "initial commit")) (define first (git-commit "initial commit"))
(check-equal? (string-length first) 40) (check-equal? (string-length first) 40)
(check-true (git-clean?)) (check-true (git-clean?))
(git checkout -b "work") (git 'checkout '-b "work")
(call-with-output-file (build-path "sub" "hello.txt") (call-with-output-file (build-path "sub" "hello.txt")
#:exists 'truncate/replace #:exists 'truncate/replace
(lambda (out) (displayln "work" out))) (lambda (out) (displayln "work" out)))
(git add) (git 'add)
(git commit "work change") (git 'commit "work change")
(check-equal? (file->string (build-path "sub" "hello.txt")) "work\n") (check-equal? (file->string (build-path "sub" "hello.txt")) "work\n")
(git checkout "master") (git 'checkout "master")
(check-equal? (file->string (build-path "sub" "hello.txt")) "hello\n") (check-equal? (file->string (build-path "sub" "hello.txt")) "hello\n")
(check-equal? (git-current-branch) "master") (check-equal? (git-current-branch) "master")
(check-not-false (member "work" (git branch))) (check-not-false (member "work" (git 'branch)))
(git branch -d "work") (git 'branch '-d "work")
(check-false (member "work" (git branch))) (check-false (member "work" (git 'branch)))
(define tag-id (git tag "v0.1")) (define tag-id (git 'tag "v0.1"))
(check-equal? (string-length tag-id) 40) (check-equal? (string-length tag-id) 40)
(check-equal? (git tag) '("v0.1")) (check-equal? (git 'tag) '("v0.1"))
(git checkout "v0.1") (git 'checkout "v0.1")
(check-false (git-current-branch)) (check-false (git-current-branch))
(git checkout "master") (git 'checkout "master")
(git tag -d "v0.1") (git 'tag '-d "v0.1")
(check-equal? (git tag) '()) (check-equal? (git 'tag) '())
(check-equal? (length (git log 10)) 1))) (check-equal? (length (git 'log 10)) 1)))
(lambda () (lambda ()
(delete-directory/files tmp))) (delete-directory/files tmp)))
tests/remote.rkt
+23 -23
View File
@@ -10,8 +10,8 @@
(define b (build-path tmp "b")) (define b (build-path tmp "b"))
(define (configure!) (define (configure!)
(git config "user.name" "Racket Git Test") (git 'config "user.name" "Racket Git Test")
(git config "user.email" "racket-git-test@example.invalid")) (git 'config "user.email" "racket-git-test@example.invalid"))
(dynamic-wind (dynamic-wind
void void
@@ -20,17 +20,17 @@
(make-directory a) (make-directory a)
(parameterize ([current-directory a]) (parameterize ([current-directory a])
(git init) (git 'init)
(configure!) (configure!)
(call-with-output-file "value.txt" (call-with-output-file "value.txt"
#:exists 'truncate/replace #:exists 'truncate/replace
(lambda (out) (displayln "one" out))) (lambda (out) (displayln "one" out)))
(git add "value.txt") (git 'add "value.txt")
(git commit "one") (git 'commit "one")
(git remote add "origin" (path->string origin)) (git 'remote 'add "origin" (path->string origin))
(check-equal? (git remote) '("origin")) (check-equal? (git 'remote) '("origin"))
(check-equal? (git remote get-url "origin") (path->string origin)) (check-equal? (git 'remote 'get-url "origin") (path->string origin))
(git push)) (git 'push))
(git-clone (path->string origin) b) (git-clone (path->string origin) b)
(parameterize ([current-directory b]) (parameterize ([current-directory b])
@@ -39,38 +39,38 @@
(call-with-output-file "value.txt" (call-with-output-file "value.txt"
#:exists 'truncate/replace #:exists 'truncate/replace
(lambda (out) (displayln "two" out))) (lambda (out) (displayln "two" out)))
(git add "value.txt") (git 'add "value.txt")
(git commit "two") (git 'commit "two")
(git push) (git 'push)
(git tag "v2") (git 'tag "v2")
(git push-tag "v2")) (git 'push-tag "v2"))
(parameterize ([current-directory a]) (parameterize ([current-directory a])
(check-equal? (file->string "value.txt") "one\n") (check-equal? (file->string "value.txt") "one\n")
(check-equal? (string-length (git pull)) 40) (check-equal? (string-length (git 'pull)) 40)
(check-equal? (file->string "value.txt") "two\n") (check-equal? (file->string "value.txt") "two\n")
(check-true (git-clean?)) (check-true (git-clean?))
(git fetch) (git 'fetch)
(check-equal? (git tag) '("v2")) (check-equal? (git 'tag) '("v2"))
(call-with-output-file "local.txt" (call-with-output-file "local.txt"
#:exists 'truncate/replace #:exists 'truncate/replace
(lambda (out) (displayln "local" out))) (lambda (out) (displayln "local" out)))
(git add "local.txt") (git 'add "local.txt")
(git commit "local change")) (git 'commit "local change"))
(parameterize ([current-directory b]) (parameterize ([current-directory b])
(call-with-output-file "remote.txt" (call-with-output-file "remote.txt"
#:exists 'truncate/replace #:exists 'truncate/replace
(lambda (out) (displayln "remote" out))) (lambda (out) (displayln "remote" out)))
(git add "remote.txt") (git 'add "remote.txt")
(git commit "remote change") (git 'commit "remote change")
(git push)) (git 'push))
(parameterize ([current-directory a]) (parameterize ([current-directory a])
(define before (git-head)) (define before (git-head))
(check-exn #rx"non-fast-forward" (check-exn #rx"non-fast-forward"
(lambda () (git pull))) (lambda () (git 'pull)))
(check-equal? (git-head) before) (check-equal? (git-head) before)
(check-true (file-exists? "local.txt")) (check-true (file-exists? "local.txt"))
(check-false (file-exists? "remote.txt")))) (check-false (file-exists? "remote.txt"))))