94 lines
3.2 KiB
Scheme
94 lines
3.2 KiB
Scheme
;; Mike Burns, July 8th, 2004, netgeek@speakeasy.net
|
|
;; Useful assertions
|
|
(module assertions mzscheme
|
|
(require (lib "test.ss" "schemeunit")
|
|
(lib "web-server.ss" "web-server")
|
|
(lib "configuration.ss" "web-server")
|
|
net/url
|
|
net/head
|
|
mzlib/contract)
|
|
|
|
(provide assert-serve assert-serve/string assert-status-number assert-with-server)
|
|
(provide/contract
|
|
(start-server (-> (-> any)))
|
|
(full-url (string? . -> . url?))
|
|
(web-root path?)
|
|
(input-port-equal? (input-port? input-port? . -> . boolean?))
|
|
(THE-PORT number?)
|
|
(THE-IP string?))
|
|
|
|
(define THE-PORT 8135)
|
|
|
|
(define THE-IP "127.0.0.1")
|
|
|
|
(define web-root (build-path (collection-path "tests")
|
|
"web-server"
|
|
"scheme-units"
|
|
"test-web-root"))
|
|
|
|
(define-simple-assertion (assert-serve url-path file-path content-type)
|
|
(assert-with-server
|
|
url-path
|
|
(lambda (http-port)
|
|
(and (content-type-equal? (purify-port http-port) content-type)
|
|
(call-with-input-file
|
|
file-path
|
|
(lambda (f-port)
|
|
(input-port-equal? http-port f-port)))))))
|
|
|
|
(define-simple-assertion (assert-serve/string url-path str content-type)
|
|
(assert-with-server
|
|
url-path
|
|
(lambda (http-port)
|
|
(and (content-type-equal? (purify-port http-port) content-type)
|
|
(let ((is (open-input-string str)))
|
|
(input-port-equal? http-port is))))))
|
|
|
|
(define-simple-assertion (assert-status-number url-path status-number)
|
|
(assert-with-server
|
|
url-path
|
|
(lambda (http-port)
|
|
(regexp-match
|
|
(format "^HTTP/... ~a" status-number)
|
|
(read-line http-port)))))
|
|
|
|
(define-simple-assertion (assert-with-server url-path assertion)
|
|
;; Ordering matters, so use let*
|
|
(let* ((stop-server (start-server))
|
|
(http-port (get-impure-port (full-url url-path))))
|
|
(begin0
|
|
(assertion http-port)
|
|
(stop-server))))
|
|
|
|
;; Format a URL
|
|
(define (full-url url-path)
|
|
(string->url (format "http://~a:~a~a" THE-IP THE-PORT url-path)))
|
|
|
|
;; Start the Web server
|
|
(define (start-server)
|
|
(serve (load-configuration (expand-path "configuration-table")) THE-PORT THE-IP))
|
|
|
|
;; It is a HTML MIME header if the Content-type header exists as a string,
|
|
;; and is "text/plain". In practice, it can be anything matching the regexp
|
|
;; "^text/plain;*.*", but not in the PLT Web server.
|
|
(define/contract content-type-equal?
|
|
(string? string? . -> . boolean?)
|
|
(lambda (header content-type)
|
|
(let ((header-content-type (extract-field "Content-type" header)))
|
|
(and header-content-type
|
|
(string? header-content-type)
|
|
(string=? header-content-type content-type)))))
|
|
|
|
;; Two input ports are equal if each line read from them are equal, and they
|
|
;; are the same size.
|
|
(define (input-port-equal? a b)
|
|
(let ((a-line (read-line a))
|
|
(b-line (read-line b)))
|
|
(cond
|
|
((eof-object? a-line) (eof-object? b-line))
|
|
((eof-object? b-line) (eof-object? a-line))
|
|
((equal? a-line b-line) (input-port-equal? a b))
|
|
(else #f))))
|
|
|
|
)
|