132 lines
4.8 KiB
Racket
132 lines
4.8 KiB
Racket
#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 c (build-path tmp "c"))
|
|
|
|
(define (configure!)
|
|
(git 'config "user.name" "Racket Git Test")
|
|
(git 'config "user.email" "racket-git-test@example.invalid"))
|
|
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(git-init origin #:bare? #t)
|
|
(make-directory a)
|
|
|
|
(parameterize ([current-directory a])
|
|
(git 'init)
|
|
(configure!)
|
|
(call-with-output-file "value.txt"
|
|
#:exists 'truncate/replace
|
|
(lambda (out) (displayln "one" out)))
|
|
(git 'add "value.txt")
|
|
(git 'commit "one")
|
|
(git 'remote 'add "origin" (path->string origin))
|
|
(check-equal? (git 'remote) '("origin"))
|
|
(check-equal? (git 'remote 'get-url "origin") (path->string origin))
|
|
(define push-out (open-output-string))
|
|
(parameterize ([current-output-port push-out])
|
|
(git 'push))
|
|
;; A successful push must remain safe when the returned credentials,
|
|
;; callbacks and options become eligible for collection.
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(define push-text (get-output-string push-out))
|
|
(check-true (regexp-match? #rx"\\[git\\] push origin/master" push-text))
|
|
(check-true (regexp-match? #rx"\\[git\\] push origin/master: done" push-text))
|
|
;; Push progress callbacks remain installed, but must not perform output
|
|
;; from FFI callback context. Percentage output would indicate a regression.
|
|
(check-false (regexp-match? #rx"%" push-text))
|
|
(define quiet-out (open-output-string))
|
|
(parameterize ([current-output-port quiet-out])
|
|
(git 'push #:quiet #t))
|
|
(check-equal? (get-output-string quiet-out) ""))
|
|
|
|
(git-clone (path->string origin) b)
|
|
(define clone-quiet-out (open-output-string))
|
|
(parameterize ([current-output-port clone-quiet-out])
|
|
(git-clone (path->string origin) c #:quiet #t))
|
|
(check-equal? (get-output-string clone-quiet-out) "")
|
|
|
|
(parameterize ([current-directory b])
|
|
(configure!)
|
|
(check-equal? (git-current-branch) "master")
|
|
(call-with-output-file "value.txt"
|
|
#:exists 'truncate/replace
|
|
(lambda (out) (displayln "two" out)))
|
|
(git 'add "value.txt")
|
|
(git 'commit "two")
|
|
(git 'push)
|
|
(git 'tag "v2")
|
|
(git 'push-tag "v2")
|
|
(define push-tag-quiet-out (open-output-string))
|
|
(parameterize ([current-output-port push-tag-quiet-out])
|
|
(git 'push-tag "v2" #:quiet #t))
|
|
(check-equal? (get-output-string push-tag-quiet-out) ""))
|
|
|
|
(parameterize ([current-directory a])
|
|
(check-equal? (file->string "value.txt") "one\n")
|
|
(check-equal? (string-length (git 'pull)) 40)
|
|
(check-equal? (file->string "value.txt") "two\n")
|
|
(check-true (git-clean?))
|
|
(git 'fetch)
|
|
(check-equal? (git 'tag) '("v2"))
|
|
(define fetch-quiet-out (open-output-string))
|
|
(parameterize ([current-output-port fetch-quiet-out])
|
|
(git 'fetch #:quiet #t))
|
|
(check-equal? (get-output-string fetch-quiet-out) "")
|
|
(define pull-quiet-out (open-output-string))
|
|
(check-false
|
|
(parameterize ([current-output-port pull-quiet-out])
|
|
(git 'pull #:quiet #t)))
|
|
(check-equal? (get-output-string pull-quiet-out) "")
|
|
|
|
(call-with-output-file "local.txt"
|
|
#:exists 'truncate/replace
|
|
(lambda (out) (displayln "local" out)))
|
|
(git 'add "local.txt")
|
|
(git 'commit "local change"))
|
|
|
|
(parameterize ([current-directory b])
|
|
(call-with-output-file "remote.txt"
|
|
#:exists 'truncate/replace
|
|
(lambda (out) (displayln "remote" out)))
|
|
(git 'add "remote.txt")
|
|
(git 'commit "remote change")
|
|
(git 'push))
|
|
|
|
(parameterize ([current-directory a])
|
|
(define before (git-head))
|
|
(check-exn #rx"non-fast-forward"
|
|
(lambda () (git 'pull)))
|
|
(check-equal? (git-head) before)
|
|
(check-true (file-exists? "local.txt"))
|
|
(check-false (file-exists? "remote.txt"))))
|
|
(lambda ()
|
|
(delete-directory/files tmp)))
|
|
|
|
;; HTTPS push without configured credentials must fail before entering libgit2.
|
|
(let ([tmp2 (make-temporary-file "racket-git-https-test~a" 'directory)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(parameterize ([current-directory tmp2])
|
|
(git 'init)
|
|
(configure!)
|
|
(call-with-output-file "x.txt" #:exists 'truncate/replace
|
|
(lambda (out) (displayln "x" out)))
|
|
(git 'add "x.txt")
|
|
(git 'commit "x")
|
|
(git 'remote 'add "origin" "https://example.invalid/private/repo.git")
|
|
(check-exn #rx"no HTTPS credentials are stored"
|
|
(lambda () (git 'push)))))
|
|
(lambda () (delete-directory/files tmp2))))
|