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
(require git)
(git status)
(git add "main.rkt" "info.rkt")
(git commit "Implement raco support")
(git tag "v0.2")
(git checkout "main")
(git 'status)
(git 'add "main.rkt" "info.rkt")
(git 'commit "Implement raco support")
(git 'tag "v0.2")
(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`.
## HTTPS credentials
@@ -24,13 +30,13 @@ PBKDF2-HMAC-SHA256.
Create the credential store once:
```racket
(git credentials init "store password")
(git 'credentials 'init "store password")
```
Store a token for a Git host:
```racket
(git credentials set
(git 'credentials 'set
"https://git.dijkewijk.nl"
"hans"
token)
@@ -42,13 +48,13 @@ repositories on that host.
The store is unlocked for one day by default:
```racket
(git credentials unlock "store password")
(git 'credentials 'unlock "store password")
```
or for an explicit number of seconds:
```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
@@ -61,16 +67,16 @@ so `racket-git-unlock.ini` must be treated as sensitive during that period.
Lock immediately with:
```racket
(git credentials lock)
(git 'credentials 'lock)
```
After credentials have been stored and the store is unlocked, normal remote
operations use them automatically:
```racket
(git fetch)
(git pull)
(git push)
(git 'fetch)
(git 'pull)
(git 'push)
```
## Supported Git operations
info.rkt
+1 -1
View File
@@ -2,7 +2,7 @@
(define collection "git")
(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 license 'MIT)
main.rkt
+92 -41
View File
@@ -2,6 +2,7 @@
(require ffi/unsafe
racket/list
racket/match
racket/path
racket/string
"credentials.rkt"
@@ -11,6 +12,7 @@
_git_error_code/check))
(provide git
dgit
git-repository?
git-root
git-init
@@ -555,44 +557,93 @@
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)]))
(define (git command . args)
(unless (symbol? command)
(raise-argument-error 'git "symbol?" command))
(case command
[(init) (apply git-init args)]
[(clone) (apply git-clone args)]
[(status) (apply git-status args)]
[(add) (apply git-add args)]
[(config) (apply git-config args)]
[(commit) (apply git-commit args)]
[(branch)
(match args
[(list '-d name) (git-branch-delete name)]
[_ (apply git-branch args)])]
[(checkout)
(match args
[(list '-b name) (git-checkout-new name)]
[_ (apply git-checkout args)])]
[(tag)
(match args
[(list '-d name) (git-tag-delete name)]
[_ (apply git-tag args)])]
[(log) (apply git-log args)]
[(remote)
(match args
['() (git-remotes)]
[(list 'add name url) (git-remote-add name url)]
[(list 'get-url name) (git-remote-url name)]
[_ (error 'git "invalid remote arguments: ~e" args)])]
[(fetch) (apply git-fetch args)]
[(pull) (apply git-pull args)]
[(push) (apply git-push args)]
[(push-tag) (apply git-push-tag args)]
[(credentials)
(match args
[(list 'init password) (git-credentials-init! password)]
[(list 'unlock password) (git-credentials-unlock! password)]
[(list 'unlock password seconds)
(git-credentials-unlock! password #:for seconds)]
[(list 'lock) (git-credentials-lock!)]
[(list 'unlocked?) (git-credentials-unlocked?)]
[(list 'set remote username token)
(git-credentials-set! remote username token)]
[(list '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[
(require git)
(git status)
(git add "main.rkt" "info.rkt")
(git commit "Implement raco support")
(git tag "v0.1")
(git checkout "main")
(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].
@defproc[(git [command symbol?] [argument any/c] ...) any/c]{
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}
@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:
@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")
(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}
tests/basic.rkt
+29 -19
View File
@@ -11,13 +11,13 @@
(lambda ()
(make-directory (build-path tmp "sub"))
(parameterize ([current-directory tmp])
(git init)
(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")
(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"
@@ -33,41 +33,51 @@
(check-equal? (git-status-lines)
'("?? .gitignore" "?? sub/hello.txt"))
(define status-output (open-output-string))
(define displayed-status
(parameterize ([current-output-port status-output])
(dgit 'status)))
(check-equal? displayed-status (git 'status))
(check-equal? (get-output-string status-output)
"New - .gitignore\nNew - sub/hello.txt\n")
(check-false (regexp-match? #rx"ignored[.]txt"
(get-output-string status-output)))
(parameterize ([current-directory (build-path tmp "sub")])
(git add "hello.txt"))
(git 'add "hello.txt"))
(check-equal? (git-status-lines)
'("?? .gitignore" "A sub/hello.txt"))
(git add ".gitignore")
(git 'add ".gitignore")
(define first (git-commit "initial commit"))
(check-equal? (string-length first) 40)
(check-true (git-clean?))
(git checkout -b "work")
(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")
(git 'add)
(git 'commit "work change")
(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? (git-current-branch) "master")
(check-not-false (member "work" (git branch)))
(check-not-false (member "work" (git 'branch)))
(git branch -d "work")
(check-false (member "work" (git branch)))
(git 'branch '-d "work")
(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? (git tag) '("v0.1"))
(git checkout "v0.1")
(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) '())
(git 'checkout "master")
(git 'tag '-d "v0.1")
(check-equal? (git 'tag) '())
(check-equal? (length (git log 10)) 1)))
(check-equal? (length (git 'log 10)) 1)))
(lambda ()
(delete-directory/files tmp)))
tests/remote.rkt
+23 -23
View File
@@ -10,8 +10,8 @@
(define b (build-path tmp "b"))
(define (configure!)
(git config "user.name" "Racket Git Test")
(git config "user.email" "racket-git-test@example.invalid"))
(git 'config "user.name" "Racket Git Test")
(git 'config "user.email" "racket-git-test@example.invalid"))
(dynamic-wind
void
@@ -20,17 +20,17 @@
(make-directory a)
(parameterize ([current-directory a])
(git init)
(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 '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])
@@ -39,38 +39,38 @@
(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"))
(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? (string-length (git 'pull)) 40)
(check-equal? (file->string "value.txt") "two\n")
(check-true (git-clean?))
(git fetch)
(check-equal? (git tag) '("v2"))
(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"))
(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))
(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)))
(lambda () (git 'pull)))
(check-equal? (git-head) before)
(check-true (file-exists? "local.txt"))
(check-false (file-exists? "remote.txt"))))