mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

add tests for read-request-line, etc.

Browse source 
* test-suite/web/web-http.test ("read-request-line"):
  ("write-request-line", "read-response-line", "write-response-line"):
  Add.
This commit is contained in:
Daniel Hartwig 2013-02-23 15:15:33 +08:00
parent dc87126115
commit 2e08ff38b7
1 changed files with 107 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

107
test-suite/tests/web-http.test
View file

@ -85,6 +85,113 @@
#t #t
(error "unexpected exception" component arg)))))))) (error "unexpected exception" component arg))))))))
(define-syntax pass-if-read-request-line
(syntax-rules ()
((_ str expected-method expected-uri expected-version)
(pass-if str
(equal? (call-with-values
(lambda ()
(read-request-line (open-input-string
(string-append str "\r\n"))))
list)
(list 'expected-method
expected-uri
'expected-version))))))
(define-syntax pass-if-write-request-line
(syntax-rules ()
((_ expected-str method uri version)
(pass-if expected-str
(equal? (string-append expected-str "\r\n")
(call-with-output-string
(lambda (port)
(write-request-line 'method uri 'version port))))))))
(define-syntax pass-if-read-response-line
(syntax-rules ()
((_ str expected-version expected-code expected-phrase)
(pass-if str
(equal? (call-with-values
(lambda ()
(read-response-line (open-input-string
(string-append str "\r\n"))))
list)
(list 'expected-version
expected-code
expected-phrase))))))
(define-syntax pass-if-write-response-line
(syntax-rules ()
((_ expected-str version code phrase)
(pass-if expected-str
(equal? (string-append expected-str "\r\n")
(call-with-output-string
(lambda (port)
(write-response-line 'version code phrase port))))))))
(with-test-prefix "read-request-line"
(pass-if-read-request-line "GET / HTTP/1.1"
GET
(build-uri 'http
#:path "/")
(1 . 1))
(pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1"
GET
(build-uri 'http
#:host "www.w3.org"
#:path "/pub/WWW/TheProject.html")
(1 . 1))
(pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
GET
(build-uri 'http
#:path "/pub/WWW/TheProject.html")
(1 . 1))
(pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
HEAD
(build-uri 'http
#:path "/etc/hosts"
#:query "foo=bar")
(1 . 1)))
(with-test-prefix "write-request-line"
(pass-if-write-request-line "GET / HTTP/1.1"
GET
(build-uri 'http
#:path "/")
(1 . 1))
;;; FIXME: Test fails due to scheme, host always being removed.
;;; However, it should be supported to request these be present, and
;;; that is possible with absolute/relative URI support.
;; (pass-if-write-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1"
;; GET
;; (build-uri 'http
;; #:host "www.w3.org"
;; #:path "/pub/WWW/TheProject.html")
;; (1 . 1))
(pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
GET
(build-uri 'http
#:path "/pub/WWW/TheProject.html")
(1 . 1))
(pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
HEAD
(build-uri 'http
#:path "/etc/hosts"
#:query "foo=bar")
(1 . 1)))
(with-test-prefix "read-response-line"
(pass-if-read-response-line "HTTP/1.0 404 Not Found"
(1 . 0) 404 "Not Found")
(pass-if-read-response-line "HTTP/1.1 200 OK"
(1 . 1) 200 "OK"))
(with-test-prefix "write-response-line"
(pass-if-write-response-line "HTTP/1.0 404 Not Found"
(1 . 0) 404 "Not Found")
(pass-if-write-response-line "HTTP/1.1 200 OK"
(1 . 1) 200 "OK"))
(with-test-prefix "general headers" (with-test-prefix "general headers"
(pass-if-parse cache-control "no-transform" '(no-transform)) (pass-if-parse cache-control "no-transform" '(no-transform))