135 lines
4.7 KiB
Racket
135 lines
4.7 KiB
Racket
#lang racket/base
|
|
(require net/git-checkout
|
|
racket/file
|
|
racket/system
|
|
web-server/servlet-env)
|
|
|
|
(define git-exe
|
|
(find-executable-path (if (eq? 'windows (system-type))
|
|
"git.exe"
|
|
"git")))
|
|
|
|
(define (git . args)
|
|
(unless (apply system* git-exe args)
|
|
(error "failed")))
|
|
|
|
(define (make-file p content)
|
|
(call-with-output-file
|
|
p
|
|
#:exists 'truncate
|
|
(lambda (o) (write-bytes content o))))
|
|
|
|
(define (filter-source l)
|
|
(filter (lambda (p) (not (equal? p (string->path ".git")))) l))
|
|
|
|
(define (compare a b)
|
|
(cond
|
|
[(link-exists? a)
|
|
(unless (link-exists? b)
|
|
(error 'compare "not both links: ~s and ~s" a b))
|
|
(define ra (resolve-path a))
|
|
(define rb (resolve-path b))
|
|
(unless (equal? ra rb)
|
|
(error 'compare "different link targets: ~s to ~s vs. ~s to ~s"
|
|
a ra b rb))]
|
|
[(directory-exists? a)
|
|
(unless (directory-exists? b)
|
|
(error 'compare "not both dirs: ~s and ~s" a b))
|
|
(define al (filter-source (directory-list a)))
|
|
(define bl (directory-list b))
|
|
(unless (equal? al bl)
|
|
(error 'compare "different content: ~s with ~s versus ~s with ~s"
|
|
a al b bl))
|
|
(for ([ap (in-list al)]
|
|
[bp (in-list bl)])
|
|
(compare (build-path a ap) (build-path b bp)))]
|
|
[(file-exists? a)
|
|
(unless (file-exists? b)
|
|
(error 'compare "not both files: ~s and ~s" a b))
|
|
(define ba (file->bytes a))
|
|
(define bb (file->bytes b))
|
|
(unless (equal? ba bb)
|
|
(error 'compare "different file content: ~s to ~s vs. ~s to ~s"
|
|
a ba b bb))
|
|
(define pa (file-or-directory-permissions a))
|
|
(define pb (file-or-directory-permissions b))
|
|
(unless (equal? pa pb)
|
|
(error 'compare "different file permissions: ~s to ~s vs. ~s to ~s"
|
|
a pa b pb))]
|
|
[else
|
|
(error 'compare "no such file: ~s" a)]))
|
|
|
|
(when git-exe
|
|
(for ([link-mode '(rel up abs)])
|
|
(define dir (make-temporary-file "~a-git-test" 'directory))
|
|
(define http-custodian (make-custodian))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(parameterize ([current-custodian http-custodian])
|
|
(thread
|
|
(lambda ()
|
|
(serve/servlet
|
|
void
|
|
#:command-line? #t
|
|
#:extra-files-paths (list dir)
|
|
#:servlet-regexp #rx"$." ; no servlets
|
|
#:port 8950))))
|
|
|
|
(parameterize ([current-directory dir]
|
|
[current-environment-variables
|
|
(environment-variables-copy (current-environment-variables))])
|
|
(environment-variables-set! (current-environment-variables) #"GIT_DIR" #f)
|
|
(make-directory "repo")
|
|
(parameterize ([current-directory (build-path dir "repo")])
|
|
(make-file "x" #"hello")
|
|
(make-file "y" #"goodbye")
|
|
(unless (eq? (system-type) 'windows)
|
|
(file-or-directory-permissions "y" #o755))
|
|
(make-file "z" #"whatever")
|
|
(unless (eq? (system-type) 'windows)
|
|
(file-or-directory-permissions "z" #o644))
|
|
(make-directory "nested")
|
|
(make-file "nested/x" #"stuff")
|
|
(unless (eq? (system-type) 'windows)
|
|
(case link-mode
|
|
[(abs)
|
|
(make-file-or-directory-link "/tmp/x" "abs-x")]
|
|
[(up)
|
|
(make-file-or-directory-link "../x" "abs-x")]
|
|
[else
|
|
(make-file-or-directory-link "x" "also-x")]))
|
|
(git "init")
|
|
(git "add" ".")
|
|
(git "commit" "-m" "initial commit")
|
|
(git "update-server-info"))
|
|
|
|
(git-checkout "localhost" #:port 8950 #:transport 'http
|
|
"repo/.git"
|
|
#:dest-dir "also-repo")
|
|
(compare "repo" "also-repo")
|
|
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(case link-mode
|
|
[(abs up)
|
|
(if (regexp-match? #rx"won't extract" (exn-message exn))
|
|
(printf "correct failure\n")
|
|
(raise exn))]
|
|
[else (raise exn)]))])
|
|
(git-checkout "localhost" #:port 8950 #:transport 'http
|
|
"repo/.git"
|
|
#:dest-dir "safe-repo"
|
|
#:strict-links? #t)
|
|
(case link-mode
|
|
[(abs up) (unless (eq? 'windows (system-type))
|
|
(error "should not have worked"))])
|
|
(compare "repo" "safe-repo"))
|
|
|
|
(void)))
|
|
(lambda ()
|
|
(custodian-shutdown-all http-custodian)
|
|
(delete-directory/files dir)))))
|
|
|
|
|