mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
7095a536f3
Based on a patch by Daniel Hartwig <mandyke@gmail.com>.
* NEWS: Update.
* doc/ref/web.texi (URIs): Fragments are properly part of a URI, so
remove the incorrect note. Add documentation on URI subtypes.
* module/web/uri.scm (uri-reference?): New base type predicate.
(uri?, relative-ref?): Specific predicates.
(validate-uri-reference): Strict validation.
(validate-uri, validate-relative-ref): Specific validators.
(build-uri-reference, build-relative-ref): New constructors.
(string->uri-reference): Rename from string->uri.
(string->uri, string->relative-ref): Specific constructors.
(uri->string): Add #:include-fragment? keyword argument.
* module/web/http.scm (parse-request-uri): Use `build-uri-reference',
and result is a URI-reference, not URI, object. No longer infer an
absent `uri-scheme' is `http'.
(write-uri): Just use `uri->string'.
(declare-uri-header!): Remove unused function.
(declare-uri-reference-header!): Update. Rename from
`declare-relative-uri-header!'.
* test-suite/tests/web-uri.test ("build-uri-reference"):
("string->uri-reference"): Add.
("uri->string"): Also tests for relative-refs.
* test-suite/tests/web-http.test ("read-request-line"):
("write-request-line"): Update for no scheme in some URIs.
("entity headers", "request headers"): Content-location, Referer, and
Location should also parse relative-URIs.
* test-suite/tests/web-request.test ("example-1"): Expect URI-reference
with no scheme.
86 lines
3.3 KiB
Scheme
86 lines
3.3 KiB
Scheme
;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
|
|
(define-module (test-suite web-request)
|
|
#:use-module (web uri)
|
|
#:use-module (web request)
|
|
#:use-module (test-suite lib))
|
|
|
|
|
|
;; The newlines are equivalent to \n.
|
|
(define example-1
|
|
"GET /qux HTTP/1.1\r
|
|
Host: localhost:8080\r
|
|
User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2\r
|
|
Accept: application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r
|
|
Accept-Encoding: gzip\r
|
|
Accept-Language: en-gb, en;q=0.9\r
|
|
\r
|
|
")
|
|
|
|
(define (requests-equal? r1 r2)
|
|
(and (equal? (request-method r1) (request-method r2))
|
|
(equal? (request-uri r1) (request-uri r2))
|
|
(equal? (request-version r1) (request-version r2))
|
|
(equal? (request-headers r1) (request-headers r2))))
|
|
|
|
(with-test-prefix "example-1"
|
|
(let ((r #f))
|
|
(pass-if "read-request"
|
|
(begin
|
|
(set! r (read-request (open-input-string example-1)))
|
|
(request? r)))
|
|
|
|
(pass-if (equal?
|
|
(request-host (build-request (string->uri "http://www.gnu.org/")))
|
|
'("www.gnu.org" . #f)))
|
|
|
|
(pass-if (equal? (request-method r) 'GET))
|
|
|
|
(pass-if (equal? (request-uri r)
|
|
(build-uri-reference #:path "/qux")))
|
|
|
|
(pass-if (equal? (read-request-body r) #f))
|
|
|
|
(pass-if "checking all headers"
|
|
(equal?
|
|
(request-headers r)
|
|
'((host . ("localhost" . 8080))
|
|
(user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2")
|
|
(accept . ((application/xml)
|
|
(application/xhtml+xml)
|
|
(text/html (q . 900))
|
|
(text/plain (q . 800))
|
|
(image/png)
|
|
(*/* (q . 500))))
|
|
(accept-encoding . ((1000 . "gzip")))
|
|
(accept-language . ((1000 . "en-gb") (900 . "en"))))))
|
|
|
|
;; works because there is no body
|
|
(pass-if "write then read"
|
|
(requests-equal? (with-input-from-string
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write-request r (current-output-port))))
|
|
(lambda ()
|
|
(read-request (current-input-port))))
|
|
r))
|
|
|
|
(pass-if "by accessor"
|
|
(equal? (request-accept-encoding r) '((1000 . "gzip"))))))
|