summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--examples/web/debug-sxml.scm4
-rw-r--r--examples/web/hello.scm2
-rw-r--r--module/web/http.scm123
-rw-r--r--module/web/server.scm16
-rw-r--r--test-suite/tests/web-http.test20
-rw-r--r--test-suite/tests/web-request.test14
-rw-r--r--test-suite/tests/web-response.test4
7 files changed, 83 insertions, 100 deletions
diff --git a/examples/web/debug-sxml.scm b/examples/web/debug-sxml.scm
index 4e6afc271..724a9bd6c 100644
--- a/examples/web/debug-sxml.scm
+++ b/examples/web/debug-sxml.scm
@@ -30,8 +30,8 @@
(status 200)
(title default-title)
(doctype html5-doctype)
- (content-type-params '(("charset" . "utf-8")))
- (content-type "text/html")
+ (content-type-params '((charset . "utf-8")))
+ (content-type 'text/html)
(extra-headers '())
(sxml (and body (templatize #:title title #:body body))))
(values (build-response
diff --git a/examples/web/hello.scm b/examples/web/hello.scm
index db17b9b5b..aa383c589 100644
--- a/examples/web/hello.scm
+++ b/examples/web/hello.scm
@@ -23,7 +23,7 @@
;; for us with a 200 OK status.
;;
(define (handler request body)
- (values '((content-type . ("text/plain")))
+ (values '((content-type . (text/plain)))
"Hello, World!"))
(run-server handler)
diff --git a/module/web/http.scm b/module/web/http.scm
index 48299818f..2c1e93a81 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -258,7 +258,7 @@ ordered alist."
(not (string-index str separators-without-slash)))))
(define (parse-media-type str)
(if (validate-media-type str)
- str
+ (string->symbol str)
(bad-header-component 'media-type str)))
(define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
@@ -467,13 +467,11 @@ ordered alist."
(define (non-negative-integer? code)
(and (number? code) (>= code 0) (exact? code) (integer? code)))
-(define (default-kons k val)
- (if val
- (cons k val)
- k))
+(define (default-val-parser k val)
+ val)
-(define (default-kv-validator k val)
- #t)
+(define (default-val-validator k val)
+ (string? val))
(define (default-val-writer k val port)
(if (or (string-index val #\;)
@@ -482,8 +480,8 @@ ordered alist."
(write-qstring val port)
(display val port)))
-(define* (parse-key-value-list str #:optional (kproc identity)
- (kons default-kons)
+(define* (parse-key-value-list str #:optional
+ (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(if (not (< i end))
@@ -492,7 +490,8 @@ ordered alist."
(eq (string-index str #\= i end))
(comma (string-index str #\, i end))
(delim (min (or eq end) (or comma end)))
- (k (kproc (substring str i (trim-whitespace str i delim)))))
+ (k (string->symbol
+ (substring str i (trim-whitespace str i delim)))))
(call-with-values
(lambda ()
(if (and eq (or (not comma) (< eq comma)))
@@ -505,14 +504,15 @@ ordered alist."
(or comma end))))
(values #f delim)))
(lambda (v-str next-i)
- (let ((i (skip-whitespace str next-i end)))
+ (let ((v (val-parser k v-str))
+ (i (skip-whitespace str next-i end)))
(if (or (= i end) (eqv? (string-ref str i) #\,))
- (lp (1+ i) (cons (kons k v-str) out))
+ (lp (1+ i) (cons (if v (cons k v) k) out))
(bad-header-component 'key-value-list
(substring str start end))))))))))
(define* (key-value-list? list #:optional
- (valid? default-kv-validator))
+ (valid? default-val-validator))
(list-of? list
(lambda (elt)
(cond
@@ -542,8 +542,8 @@ ordered alist."
;; param-component = token [ "=" (token | quoted-string) ] \
;; *(";" token [ "=" (token | quoted-string) ])
;;
-(define* (parse-param-component str #:optional (kproc identity)
- (kons default-kons)
+(define* (parse-param-component str #:optional
+ (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(if (not (< i end))
@@ -551,7 +551,7 @@ ordered alist."
(let ((delim (string-index str
(lambda (c) (memq c '(#\, #\; #\=)))
i)))
- (let ((k (kproc
+ (let ((k (string->symbol
(substring str i (trim-whitespace str i (or delim end)))))
(delimc (and delim (string-ref str delim))))
(case delimc
@@ -573,8 +573,9 @@ ordered alist."
(values (substring str i delim)
delim)))))
(lambda (v-str next-i)
- (let ((x (kons k v-str))
- (i (skip-whitespace str next-i end)))
+ (let* ((v (val-parser k v-str))
+ (x (if v (cons k v) k))
+ (i (skip-whitespace str next-i end)))
(case (and (< i end) (string-ref str i))
((#f)
(values (reverse! (cons x out)) end))
@@ -584,19 +585,21 @@ ordered alist."
(else ; including #\,
(values (reverse! (cons x out)) i)))))))
((#\;)
- (lp (skip-whitespace str (1+ delim) end)
- (cons (kons k #f) out)))
+ (let ((v (val-parser k #f)))
+ (lp (skip-whitespace str (1+ delim) end)
+ (cons (if v (cons k v) k) out))))
(else ;; either the end of the string or a #\,
- (values (reverse! (cons (kons k #f) out))
- (or delim end)))))))))
+ (let ((v (val-parser k #f)))
+ (values (reverse! (cons (if v (cons k v) k) out))
+ (or delim end))))))))))
(define* (parse-param-list str #:optional
- (kproc identity) (kons default-kons)
+ (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(call-with-values
- (lambda () (parse-param-component str kproc kons i end))
+ (lambda () (parse-param-component str val-parser i end))
(lambda (item i)
(if (< i end)
(if (eqv? (string-ref str i) #\,)
@@ -606,7 +609,7 @@ ordered alist."
(reverse! (cons item out)))))))
(define* (validate-param-list list #:optional
- (valid? default-kv-validator))
+ (valid? default-val-validator))
(list-of? list
(lambda (elt)
(key-value-list? list valid?))))
@@ -881,23 +884,21 @@ phrase\"."
;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1)
(define* (declare-param-list-header! name #:optional
- (kproc identity)
- (kons default-kons)
- (val-validator default-kv-validator)
+ (val-parser default-val-parser)
+ (val-validator default-val-validator)
(val-writer default-val-writer))
(declare-header! name
- (lambda (str) (parse-param-list str kproc kons))
+ (lambda (str) (parse-param-list str val-parser))
(lambda (val) (validate-param-list val val-validator))
(lambda (val port) (write-param-list val port val-writer))))
;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1)
(define* (declare-key-value-list-header! name #:optional
- (kproc identity)
- (kons default-kons)
- (val-validator default-kv-validator)
+ (val-parser default-val-parser)
+ (val-validator default-val-validator)
(val-writer default-val-writer))
(declare-header! name
- (lambda (str) (parse-key-value-list str kproc kons))
+ (lambda (str) (parse-key-value-list str val-parser))
(lambda (val) (key-value-list? val val-validator))
(lambda (val port) (write-key-value-list val port val-writer))))
@@ -943,24 +944,14 @@ phrase\"."
;; cache-extension = token [ "=" ( token | quoted-string ) ]
;;
(declare-key-value-list-header! "Cache-Control"
- (let ((known-directives (make-hash-table)))
- (for-each (lambda (s)
- (hash-set! known-directives s (string->symbol s)))
- '("no-cache" "no-store" "max-age" "max-stale" "min-fresh"
- "no-transform" "only-if-cached" "public" "private"
- "must-revalidate" "proxy-revalidate" "s-maxage"))
- (lambda (k-str)
- (hash-ref known-directives k-str k-str)))
(lambda (k v-str)
(case k
((max-age max-stale min-fresh s-maxage)
- (cons k (parse-non-negative-integer v-str)))
+ (parse-non-negative-integer v-str))
((private no-cache)
- (if v-str
- (cons k (split-header-names v-str))
- k))
- (else (if v-str (cons k v-str) k))))
- default-kv-validator
+ (and v-str (split-header-names v-str)))
+ (else v-str)))
+ default-val-validator
(lambda (k v port)
(cond
((string? v) (display v port))
@@ -990,8 +981,7 @@ phrase\"."
;; pragma-directive = "no-cache" | extension-pragma
;; extension-pragma = token [ "=" ( token | quoted-string ) ]
;;
-(declare-key-value-list-header! "Pragma"
- (lambda (k) (if (equal? k "no-cache") 'no-cache k)))
+(declare-key-value-list-header! "Pragma")
;; Trailer = "Trailer" ":" 1#field-name
;;
@@ -999,9 +989,7 @@ phrase\"."
;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
;;
-(declare-param-list-header! "Transfer-Encoding"
- (lambda (k)
- (if (equal? k "chunked") 'chunked k)))
+(declare-param-list-header! "Transfer-Encoding")
;; Upgrade = "Upgrade" ":" 1#product
;;
@@ -1185,16 +1173,17 @@ phrase\"."
(map (lambda (x)
(let ((eq (string-index x #\=)))
(if (and eq (= eq (string-rindex x #\=)))
- (cons (string-trim x char-whitespace? 0 eq)
+ (cons (string->symbol
+ (string-trim x char-whitespace? 0 eq))
(string-trim-right x char-whitespace? (1+ eq)))
(bad-header 'content-type str))))
(cdr parts)))))
(lambda (val)
(and (pair? val)
- (string? (car val))
+ (symbol? (car val))
(list-of? (cdr val)
(lambda (x)
- (and (pair? x) (string? (car x)) (string? (cdr x)))))))
+ (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
(lambda (val port)
(display (car val) port)
(if (pair? (cdr val))
@@ -1230,20 +1219,19 @@ phrase\"."
;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
;;
(declare-param-list-header! "Accept"
- ;; -> ("type/subtype" (str-prop . str-val) ...) ...)
+ ;; -> (type/subtype (sym-prop . str-val) ...) ...)
;;
- ;; with the exception of prop = "q", in which case the prop will be
- ;; the symbol 'q, and the val will be a valid quality value
+ ;; with the exception of prop `q', in which case the val will be a
+ ;; valid quality value
;;
- (lambda (k) (if (string=? k "q") 'q k))
(lambda (k v)
- (if (eq? k 'q)
- (cons k (parse-quality v))
- (default-kons k v)))
+ (if (eq? k 'q)
+ (parse-quality v)
+ v))
(lambda (k v)
(if (eq? k 'q)
(valid-quality? v)
- (default-kv-validator k v)))
+ (string? v)))
(lambda (k v port)
(if (eq? k 'q)
(write-quality v port)
@@ -1276,11 +1264,7 @@ phrase\"."
;; *expect-params ]
;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
;;
-(declare-param-list-header! "Expect"
- (lambda (k)
- (if (equal? k "100-continue")
- '100-continue
- k)))
+(declare-param-list-header! "Expect")
;; From = mailbox
;;
@@ -1407,8 +1391,7 @@ phrase\"."
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;;
-(declare-param-list-header! "TE"
- (lambda (k) (if (equal? k "trailers") 'trailers k)))
+(declare-param-list-header! "TE")
;; User-Agent = 1*( product | comment )
;;
diff --git a/module/web/server.scm b/module/web/server.scm
index 042e4f1ca..02d01b088 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -1,6 +1,6 @@
;;; Web server
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 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
@@ -219,27 +219,27 @@ on the procedure being called at any particular time."
(values response #vu8()))
((string? body)
(let* ((type (response-content-type response
- '("text/plain")))
- (declared-charset (assoc-ref (cdr type) "charset"))
+ '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
(charset (or declared-charset "utf-8")))
(sanitize-response
request
(if declared-charset
response
(extend-response response 'content-type
- `(,@type ("charset" . ,charset))))
+ `(,@type (charset . ,charset))))
(encode-string body charset))))
((procedure? body)
(let* ((type (response-content-type response
- '("text/plain")))
- (declared-charset (assoc-ref (cdr type) "charset"))
+ '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
(charset (or declared-charset "utf-8")))
(sanitize-response
request
(if declared-charset
response
(extend-response response 'content-type
- `(,@type ("charset" . ,charset))))
+ `(,@type (charset . ,charset))))
(call-with-encoded-output-string charset body))))
((bytevector? body)
;; check length; assert type; add other required fields?
@@ -370,7 +370,7 @@ For example, here is a simple \"Hello, World!\" server:
@example
(define (handler request body)
- (values '((content-type . (\"text/plain\")))
+ (values '((content-type . (text/plain)))
\"Hello, World!\"))
(run-server handler)
@end example
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index bf030a940..aa7ddf670 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -74,7 +74,7 @@
(with-test-prefix "general headers"
(pass-if-parse cache-control "no-transform" '(no-transform))
- (pass-if-parse cache-control "no-transform,foo" '(no-transform "foo"))
+ (pass-if-parse cache-control "no-transform,foo" '(no-transform foo))
(pass-if-parse cache-control "no-cache" '(no-cache))
(pass-if-parse cache-control "no-cache=\"Authorization, Date\""
'((no-cache . (authorization date))))
@@ -93,12 +93,12 @@
(pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
(pass-if-parse pragma "no-cache" '(no-cache))
- (pass-if-parse pragma "no-cache, foo" '(no-cache "foo"))
+ (pass-if-parse pragma "no-cache, foo" '(no-cache foo))
(pass-if-parse trailer "foo, bar" '(foo bar))
(pass-if-parse trailer "connection, bar" '(connection bar))
- (pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked)))
+ (pass-if-parse transfer-encoding "foo, chunked" '((foo) (chunked)))
(pass-if-parse upgrade "qux" '("qux"))
@@ -125,8 +125,8 @@
(pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *))
(pass-if-parse content-range "bytes */*" '(bytes * *))
(pass-if-parse content-range "bytes */30" '(bytes * 30))
- (pass-if-parse content-type "foo/bar" '("foo/bar"))
- (pass-if-parse content-type "foo/bar; baz=qux" '("foo/bar" ("baz" . "qux")))
+ (pass-if-parse content-type "foo/bar" '(foo/bar))
+ (pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux")))
(pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT"
(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
@@ -136,9 +136,9 @@
(with-test-prefix "request headers"
(pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1"
- '(("text/*" (q . 300))
- ("text/html" (q . 700))
- ("text/html" ("level" . "1"))))
+ '((text/* (q . 300))
+ (text/html (q . 700))
+ (text/html (level . "1"))))
(pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8"
'((1000 . "iso-8859-5") (800 . "unicode-1-1")))
(pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0"
@@ -150,7 +150,7 @@
;; Allow nonstandard .2 to mean 0.2
(pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
(pass-if-parse authorization "foo" "foo")
- (pass-if-parse expect "100-continue, foo" '((100-continue) ("foo")))
+ (pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
(pass-if-parse from "foo@bar" "foo@bar")
(pass-if-parse host "qux" '("qux" . #f))
(pass-if-parse host "qux:80" '("qux" . 80))
@@ -180,7 +180,7 @@
(pass-if-parse referer "http://foo/bar?baz"
(build-uri 'http #:host "foo" #:path "/bar" #:query "baz"))
(pass-if-parse te "trailers" '((trailers)))
- (pass-if-parse te "trailers,foo" '((trailers) ("foo")))
+ (pass-if-parse te "trailers,foo" '((trailers) (foo)))
(pass-if-parse user-agent "guile" "guile"))
diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test
index 82759bd6b..32b99dd99 100644
--- a/test-suite/tests/web-request.test
+++ b/test-suite/tests/web-request.test
@@ -1,6 +1,6 @@
;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011 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
@@ -61,12 +61,12 @@ Accept-Language: en-gb, en;q=0.9\r
(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 . ((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"))))))
diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test
index 7c942754f..278b0b3e3 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011 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
@@ -79,7 +79,7 @@ abcdefghijklmnopqrstuvwxyz0123456789")
(vary . (accept-encoding))
(content-encoding . ("gzip"))
(content-length . 36)
- (content-type . ("text/html" ("charset" . "utf-8"))))))
+ (content-type . (text/html (charset . "utf-8"))))))
(pass-if "write then read"
(call-with-values
View Lorry Controller Status