285 lines
9.4 KiB
Racket
285 lines
9.4 KiB
Racket
#lang racket/base
|
|
(require rackunit
|
|
racket/system
|
|
racket/match
|
|
(for-syntax racket/base
|
|
syntax/parse)
|
|
racket/file
|
|
racket/runtime-path
|
|
racket/path
|
|
racket/list
|
|
racket/format
|
|
racket/port
|
|
racket/string
|
|
setup/dirs
|
|
"shelly.rkt"
|
|
"git-http-proxy.rkt")
|
|
|
|
(define-runtime-path test-source-directory ".")
|
|
|
|
;; Use a consistent directory, so that individual tests can be
|
|
;; run after "tests-create.rkt":
|
|
(define-runtime-path test-directory (build-path (find-system-path 'temp-dir)
|
|
"pkg-test-work"))
|
|
|
|
(define (sync-test-directory)
|
|
(printf "Syncing test directory\n")
|
|
(make-directory* test-directory)
|
|
(parameterize ([current-directory test-source-directory])
|
|
(for ([f (in-directory)])
|
|
(define src f)
|
|
(define dest (build-path test-directory f))
|
|
(cond
|
|
[(directory-exists? src) (make-directory* dest)]
|
|
[else (copy-file src dest #t)]))))
|
|
|
|
(define-syntax-rule (this-test-is-run-by-the-main-test)
|
|
(module test racket/base))
|
|
|
|
(define (get-info-domain-cache-path)
|
|
(define c (first (current-library-collection-paths)))
|
|
(define p (build-path c "info-domain" "compiled" "cache.rktd"))
|
|
(and (file-exists? p)
|
|
p))
|
|
|
|
(define fake-installation-dir (make-parameter #f))
|
|
|
|
(define (with-fake-installation* t #:default-scope [default-scope "installation"])
|
|
(define tmp-dir
|
|
(make-temporary-file ".racket.fake-installation~a" 'directory
|
|
(find-system-path 'temp-dir)))
|
|
(make-directory* tmp-dir)
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(define ->s path->string)
|
|
(define config
|
|
(hash
|
|
;; redirect main installation via "share" to
|
|
;; our temporary directory:
|
|
'share-dir
|
|
(->s (build-path tmp-dir))
|
|
|
|
'installation-name
|
|
"test"
|
|
|
|
'default-scope
|
|
default-scope
|
|
|
|
;; Find existing links and packages from the
|
|
;; old configuration:
|
|
'links-search-files
|
|
(cons #f
|
|
(map ->s (get-links-search-files)))
|
|
'pkgs-search-dirs
|
|
(cons #f
|
|
(map ->s (get-pkgs-search-dirs)))))
|
|
(call-with-output-file*
|
|
(build-path tmp-dir "config.rktd")
|
|
(lambda (o)
|
|
(write config o)
|
|
(newline o)))
|
|
(define tmp-dir-s
|
|
(path->string tmp-dir))
|
|
(parameterize ([current-environment-variables
|
|
(environment-variables-copy
|
|
(current-environment-variables))]
|
|
[fake-installation-dir tmp-dir])
|
|
(putenv "PLTCONFIGDIR" tmp-dir-s)
|
|
(putenv "PATH" (~a (find-console-bin-dir)
|
|
":"
|
|
(getenv "PATH")))
|
|
;; Some tests use `git`; make sure those calls don't
|
|
;; operate on some other directory:
|
|
(environment-variables-set! (current-environment-variables)
|
|
#"GIT_DIR"
|
|
#f)
|
|
(t)))
|
|
(λ ()
|
|
(delete-directory/files tmp-dir))))
|
|
(define-syntax-rule (with-fake-installation e ...)
|
|
(with-fake-installation* (λ () e ...)))
|
|
|
|
(define (with-fake-root* t)
|
|
(define tmp-dir
|
|
(make-temporary-file ".racket.fake-root~a" 'directory
|
|
(find-system-path 'home-dir)))
|
|
(make-directory* tmp-dir)
|
|
(dynamic-wind
|
|
void
|
|
(λ ()
|
|
(define tmp-dir-s
|
|
(path->string tmp-dir))
|
|
(parameterize ([current-environment-variables
|
|
(environment-variables-copy
|
|
(current-environment-variables))])
|
|
(putenv "PLTADDONDIR" tmp-dir-s)
|
|
(t)))
|
|
(λ ()
|
|
(delete-directory/files tmp-dir))))
|
|
(define-syntax-rule (with-fake-root e ...)
|
|
(with-fake-root* (λ () e ...)))
|
|
|
|
(define (with-thread start-thread thunk)
|
|
(define thread-id (thread start-thread))
|
|
(dynamic-wind
|
|
void
|
|
thunk
|
|
(λ () (kill-thread thread-id))))
|
|
|
|
(require web-server/http
|
|
web-server/servlet-env)
|
|
(define (start-file-server)
|
|
(parameterize ([current-error-port (if (verbose?)
|
|
(current-output-port)
|
|
(open-output-nowhere))])
|
|
(serve/servlet (λ (req) (response/xexpr "None"))
|
|
#:command-line? #t
|
|
#:port 9997
|
|
#:extra-files-paths (list (build-path test-directory "test-pkgs")))))
|
|
|
|
(require "basic-index.rkt")
|
|
(define *index-ht-1* (make-hash))
|
|
(define *index-ht-2* (make-hash))
|
|
(define (start-pkg-server index-ht port)
|
|
(parameterize ([current-error-port (if (verbose?)
|
|
(current-output-port)
|
|
(open-output-nowhere))])
|
|
(serve/servlet (pkg-index/basic
|
|
(λ (pkg-name)
|
|
(define r (hash-ref index-ht pkg-name #f))
|
|
(when (verbose?)
|
|
(printf "[>server ~a] ~a = ~a\n" port pkg-name r))
|
|
r)
|
|
(λ () index-ht))
|
|
#:command-line? #t
|
|
#:servlet-regexp #rx""
|
|
#:port port)))
|
|
|
|
(define servers-on? #f)
|
|
(define (with-servers* t)
|
|
(cond
|
|
[servers-on?
|
|
(t)]
|
|
[else
|
|
(set! servers-on? #t)
|
|
(with-thread
|
|
(λ () (start-pkg-server *index-ht-1* 9990))
|
|
(λ ()
|
|
(with-thread
|
|
(λ () (start-pkg-server *index-ht-2* 9991))
|
|
(λ ()
|
|
(with-thread
|
|
(λ () (start-file-server))
|
|
(λ ()
|
|
(with-thread (λ () (serve-git-http-proxy! #:port 9996))
|
|
t)))))))]))
|
|
(define-syntax-rule (with-servers e ...)
|
|
(with-servers* (λ () e ...)))
|
|
|
|
(define-syntax (pkg-tests stx)
|
|
(syntax-case stx ()
|
|
[(_ e ...)
|
|
(with-syntax
|
|
([run-pkg-tests (datum->syntax #f 'run-pkg-tests)])
|
|
(syntax/loc stx
|
|
(begin
|
|
(define (run-pkg-tests)
|
|
(shelly-begin
|
|
e ...))
|
|
(provide run-pkg-tests)
|
|
(module+ main
|
|
(require racket/cmdline)
|
|
(define verb? #t)
|
|
(command-line
|
|
#:once-each
|
|
["-q" "run quietly" (set! verb? #f)]
|
|
#:args () (void))
|
|
(parameterize ([verbose? verb?])
|
|
(run-pkg-tests* run-pkg-tests))))))]))
|
|
|
|
(define (run-pkg-tests* t)
|
|
(putenv "PLT_PKG_NOSETUP" "y")
|
|
(with-servers
|
|
(with-fake-installation*
|
|
#:default-scope "user"
|
|
(lambda ()
|
|
(shelly-case "setup info cache" $ "raco setup -nDKxiI --no-foreign-libs")
|
|
(with-fake-root
|
|
(parameterize ([current-directory test-directory])
|
|
(sync-test-directory)
|
|
(t)))))))
|
|
|
|
(define-syntax-rule (shelly-install** message pkg rm-pkg (pre ...) (more ...))
|
|
(with-fake-root
|
|
(shelly-case
|
|
(format "Test installation of ~a" message)
|
|
pre ...
|
|
$ "racket -e '(require pkg-test1)'" =exit> 1
|
|
$ (format "raco pkg install --copy ~a" pkg)
|
|
$ "racket -e '(require pkg-test1)'"
|
|
more ...
|
|
$ (format "raco pkg remove ~a" rm-pkg)
|
|
$ "racket -e '(require pkg-test1)'" =exit> 1)))
|
|
|
|
(define-syntax-rule (shelly-install* message pkg rm-pkg more ...)
|
|
(shelly-install** message pkg rm-pkg () (more ...)))
|
|
|
|
(define-syntax-rule (shelly-install message pkg more ...)
|
|
(shelly-install* message pkg "pkg-test1" more ...))
|
|
|
|
(define (initialize-catalogs)
|
|
(hash-set! *index-ht-1* "pkg-test1"
|
|
(hasheq 'checksum
|
|
(file->string "test-pkgs/pkg-test1.zip.CHECKSUM")
|
|
'source
|
|
"http://localhost:9997/pkg-test1.zip"
|
|
'tags
|
|
'("first")))
|
|
|
|
(hash-set! *index-ht-1* "pkg-test2"
|
|
(hasheq 'checksum
|
|
(file->string "test-pkgs/pkg-test2.zip.CHECKSUM")
|
|
'source
|
|
"http://localhost:9997/pkg-test2.zip"
|
|
'dependencies
|
|
'("pkg-test1")))
|
|
|
|
(hash-set! *index-ht-2* "pkg-test2-snd"
|
|
(hasheq 'checksum
|
|
(file->string "test-pkgs/pkg-test2.zip.CHECKSUM")
|
|
'source
|
|
"http://localhost:9997/pkg-test2.zip"
|
|
'dependencies
|
|
'("pkg-test1")))
|
|
|
|
(initialize-catalogs/git))
|
|
|
|
(define (initialize-catalogs/git)
|
|
(define pkg-git.git (make-temporary-file "pkg-git-~a.git"))
|
|
(delete-file pkg-git.git)
|
|
(parameterize ([current-directory (build-path test-source-directory "test-pkgs")])
|
|
(copy-directory/files (build-path test-source-directory "test-pkgs" "pkg-git") pkg-git.git))
|
|
(define checksum
|
|
(parameterize ([current-directory pkg-git.git])
|
|
(system "git init")
|
|
(system "git add -A")
|
|
(system "git commit -m 'initial commit'")
|
|
(string-trim
|
|
(with-output-to-string
|
|
(λ () (system "git rev-parse HEAD"))))))
|
|
|
|
(match-define-values [_ pkg-git.git-filename _] (split-path pkg-git.git))
|
|
(hash-set! *index-ht-1* "pkg-git"
|
|
(hasheq 'checksum checksum
|
|
'source (~a "http://localhost:9996/" (path->string pkg-git.git-filename)))))
|
|
|
|
(define (set-file path content)
|
|
(make-parent-directory* path)
|
|
(call-with-output-file*
|
|
path
|
|
#:exists 'truncate/replace
|
|
(lambda (o) (displayln content o))))
|
|
|
|
(provide (all-defined-out))
|