316 lines
10 KiB
Racket
316 lines
10 KiB
Racket
#lang racket
|
|
|
|
#|
|
|
|
|
This runs a bunch of integration tests for the planet command-line tool,
|
|
using 'system' to call out to the tool and then reading its results, etc.
|
|
|
|
|#
|
|
|
|
(require racket/system
|
|
planet/config
|
|
net/url)
|
|
|
|
(define debug? #f)
|
|
|
|
(define raco-bin-path
|
|
(simplify-path (build-path (collection-path "racket") 'up 'up
|
|
(if (eq? (system-type) 'windows)
|
|
"raco.exe"
|
|
(build-path "bin" "raco")))))
|
|
|
|
(define test-connection-spec '("planet" "test-connection.plt" "1" "0"))
|
|
(define test-connection.plt-cache
|
|
(apply build-path
|
|
(UNINSTALLED-PACKAGE-CACHE)
|
|
(append test-connection-spec
|
|
(list (list-ref test-connection-spec 1)))))
|
|
|
|
(define (call-planet . args)
|
|
(when debug? (printf "~s\n" (cons 'call-planet args)))
|
|
(let ([sp (open-output-string)])
|
|
(parameterize ([current-input-port (open-input-string "")]
|
|
[current-output-port sp]
|
|
[current-error-port sp])
|
|
(apply system* raco-bin-path "planet" args))
|
|
(when debug? (display (get-output-string sp)))
|
|
(get-output-string sp)))
|
|
|
|
(let ([result (call-planet "show")])
|
|
(unless (regexp-match #rx"No packages" result)
|
|
(error 'cmdline-tool.rkt "please clear out all planet packages before running this test.\n============================================================\n~a" result)))
|
|
|
|
(when (file-exists? test-connection.plt-cache)
|
|
(delete-file test-connection.plt-cache))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; planet install, w/out cached file
|
|
;;
|
|
|
|
(define (do-install w-w/out)
|
|
(printf "Installing test-connection.plt (~a cached .plt) ... " w-w/out) (flush-output)
|
|
(void (apply call-planet "install" test-connection-spec))
|
|
(printf "done\n")
|
|
(cond
|
|
[(regexp-match #rx"test-connection.plt" (call-planet "show"))
|
|
(printf "Installed successfully\n")]
|
|
[else
|
|
(error 'cmdline-tool.rkt "Installation failed\n")])
|
|
|
|
(unless (file-exists? test-connection.plt-cache)
|
|
(error 'cmdline-tool.rkt "Installation did not populate ~s" test-connection.plt-cache)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; planet remove
|
|
;;
|
|
|
|
(define (do-remove)
|
|
(printf "Removing test-connection.plt ... ") (flush-output)
|
|
(void (apply call-planet "remove" test-connection-spec))
|
|
(printf "done\n")
|
|
(cond
|
|
[(regexp-match #rx"test-connection.plt" (call-planet "show"))
|
|
(error 'cmdline-tool.rkt "Removal failed\n")]
|
|
[else
|
|
(printf "Removed successfully\n")])
|
|
|
|
(unless (file-exists? test-connection.plt-cache)
|
|
(error 'cmdline-tool.rkt "Removal removed ~s" test-connection.plt-cache)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; planet fetch vs planet url
|
|
;;
|
|
|
|
;; NB: this test leaves behind test-connection.plt, which other tests rely on
|
|
|
|
(define (fetch-vs-url)
|
|
(define direct-file (format "direct-~a" (list-ref test-connection-spec 1)))
|
|
|
|
|
|
(ensure-not-there direct-file)
|
|
(ensure-not-there (list-ref test-connection-spec 1))
|
|
(printf "Downloading test-connection.plt (2 ways) ... ")
|
|
(flush-output)
|
|
|
|
(define direct-download-thread
|
|
(thread
|
|
(λ ()
|
|
(call-with-output-file direct-file
|
|
(λ (f-port)
|
|
(call/input-url (string->url (apply call-planet "url" test-connection-spec))
|
|
get-pure-port
|
|
(λ (u-port)
|
|
(copy-port u-port f-port))))
|
|
#:exists 'truncate))))
|
|
|
|
(void (apply call-planet "fetch" test-connection-spec))
|
|
(thread-wait direct-download-thread)
|
|
(printf "done\n")
|
|
|
|
(unless (same-file? direct-file (list-ref test-connection-spec 1))
|
|
(error 'cmdline-tool.rkt "expected planet fetch and planet url to point at the same file, but found different ones"))
|
|
|
|
(delete-file direct-file)
|
|
(printf "Download succesful\n"))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; planet fileinject
|
|
;;
|
|
|
|
(define (do-fileinject)
|
|
(printf "Running fileinject ... ")
|
|
(flush-output)
|
|
(apply call-planet "fileinject" test-connection-spec)
|
|
(printf "done\n")
|
|
(unless (regexp-match #rx"test-connection.plt" (call-planet "show"))
|
|
(error 'cmdline-tool.rkt "expected a fileinject to show up in planet info"))
|
|
(apply call-planet "remove" test-connection-spec)
|
|
(when (regexp-match #rx"test-connection.plt" (call-planet "show"))
|
|
(error 'cmdline-tool.rkt "expected remove (after fileinject) to remove test-connection.plt"))
|
|
(printf "Fileinject successful\n"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; planet sructure & open
|
|
;;
|
|
|
|
(define (do-structure)
|
|
(printf "Running open vs structure & print test ... ")
|
|
(flush-output)
|
|
(define structure-files
|
|
(filter
|
|
(λ (x) (not (equal? "" x)))
|
|
(sort
|
|
(regexp-split #rx"\n" (call-planet "structure" (list-ref test-connection-spec 1)))
|
|
string<=?)))
|
|
(define tmp-dir "test-connection-contents")
|
|
(when (directory-exists? tmp-dir)
|
|
(error 'cmdline-tool.rkt "expected the directory ~a to not exist" tmp-dir))
|
|
(call-planet "open" (list-ref test-connection-spec 1) tmp-dir)
|
|
(define open-files
|
|
(sort (let f/d-loop ([f/d #f]
|
|
[acc '()])
|
|
(let ([this-one (if f/d
|
|
(build-path tmp-dir f/d)
|
|
tmp-dir)])
|
|
(cond
|
|
[(file-exists? this-one)
|
|
(cons (path->string f/d) acc)]
|
|
[(directory-exists? this-one)
|
|
(let loop ([contents (directory-list this-one)]
|
|
[acc acc])
|
|
(cond
|
|
[(null? contents) acc]
|
|
[else
|
|
(loop (cdr contents)
|
|
(f/d-loop (if f/d
|
|
(build-path f/d (car contents))
|
|
(car contents))
|
|
acc))]))]
|
|
[else acc])))
|
|
string<=?))
|
|
|
|
(define doc.txt-print (call-planet "print" (list-ref test-connection-spec 1) "doc.txt"))
|
|
(define doc.txt-fetch (let ([sp (open-output-string)])
|
|
(call-with-input-file (build-path tmp-dir "doc.txt")
|
|
(λ (port)
|
|
(copy-port port sp)))
|
|
(get-output-string sp)))
|
|
|
|
(delete-directory/files tmp-dir)
|
|
(printf "done\n")
|
|
(unless (equal? open-files structure-files)
|
|
(error 'cmdline-tool.rkt "expected planet structure to produce the same files as planet open, got ~s and ~s"
|
|
structure-files
|
|
open-files))
|
|
|
|
(unless (equal? doc.txt-fetch doc.txt-print)
|
|
(error 'cmdline-tool.rkt "expected planet print to produce the same content as the actual file, got\n~s\nand\n~s"
|
|
doc.txt-print
|
|
doc.txt-fetch)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; planet create
|
|
;;
|
|
|
|
(define files
|
|
'(("info.rkt"
|
|
#<<--
|
|
#lang setup/infotab
|
|
|
|
(define name "the-name")
|
|
(define blurb
|
|
(list "the blurb"))
|
|
(define primary-file "main.rkt")
|
|
(define scribblings '(("doc.scrbl")))
|
|
(define release-notes '("release notes"))
|
|
(define categories '(misc))
|
|
(define repositories '("4.x"))
|
|
--
|
|
)
|
|
("doc.scrbl"
|
|
#<<--
|
|
#lang scribble/doc
|
|
@(require scribble/base)
|
|
@title{the docs}
|
|
--
|
|
)
|
|
("main.rkt" "#lang racket\n(provide the-export)\n(define the-export 1)\n")))
|
|
|
|
(define (do-create)
|
|
(printf "Running create test ... ")
|
|
(flush-output)
|
|
(define tmp-root-dir (make-temporary-file "planet-cmdline-tool-test-create-~a" 'directory))
|
|
(define tmp-dir (build-path tmp-root-dir "the-source"))
|
|
(define plt-file (build-path tmp-root-dir "the-source.plt"))
|
|
(make-directory tmp-dir)
|
|
(for ([f (in-list files)])
|
|
(define file (list-ref f 0))
|
|
(define contents (list-ref f 1))
|
|
(call-with-output-file (build-path tmp-dir file)
|
|
(λ (port) (display contents port))))
|
|
(define output (parameterize ([current-directory tmp-root-dir])
|
|
(call-planet "create" (path->string tmp-dir))))
|
|
(cond
|
|
[(or (regexp-match #rx"[Ee]rror" output)
|
|
(regexp-match #rx"Refusing" output)
|
|
(regexp-match #rx"=== context ===" output))
|
|
(eprintf "error during planet create test:\n~a" output)]
|
|
[(regexp-match #rx"WARNING" output)
|
|
(eprintf "warning during planet create test:\n~a" output)]
|
|
[else
|
|
(define contents
|
|
(filter
|
|
(λ (x) (not (equal? x "")))
|
|
(sort (regexp-split #rx"\n" (call-planet "structure" (path->string plt-file)))
|
|
string<=?)))
|
|
(unless (equal? contents
|
|
(list " index.html"
|
|
" scribble-common.js"
|
|
" scribble-style.css"
|
|
" scribble.css"
|
|
" doc:"
|
|
"doc.scrbl"
|
|
"info.rkt"
|
|
"main.rkt"
|
|
"planet-docs:"))
|
|
(eprintf "planet create test doesn't contain expected stuff; got:\n ~s\n"
|
|
contents))])
|
|
|
|
(delete-directory/files tmp-root-dir)
|
|
(printf "done\n"))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; util
|
|
;;
|
|
|
|
(define (ensure-not-there fn)
|
|
(when (file-exists? fn)
|
|
(error 'cmdline-tool.rkt
|
|
"test script expects no file named ~a to exist in the current directory (may have been left behind by test script, tho ... (which would be a bug))"
|
|
fn)))
|
|
|
|
;; same-file? : string-or-port string-or-port -> boolean
|
|
;; compares the contents of f1 and f2
|
|
(define (same-file? f1 f2)
|
|
(call-with-input-file f1
|
|
(λ (direct-port)
|
|
(call-with-input-file f2
|
|
(λ (via-planet-port)
|
|
(let loop ()
|
|
(let ([b1 (read-byte direct-port)]
|
|
[b2 (read-byte via-planet-port)])
|
|
(cond
|
|
[(equal? b1 b2)
|
|
(if (eof-object? b1)
|
|
#t
|
|
(loop))]
|
|
[else #f]))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; main
|
|
;;
|
|
|
|
(fetch-vs-url)
|
|
(do-install "without")
|
|
(do-remove)
|
|
(do-install "with")
|
|
(do-remove)
|
|
(do-fileinject)
|
|
(do-structure)
|
|
(do-create)
|
|
|
|
(delete-file (list-ref test-connection-spec 1))
|
|
(printf "Finished tests\n")
|