mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
(web http): keys are always symbols
* module/web/http.scm (parse-media-type): Parse media types as symbols.
(parse-key-value-list, parse-param-component, parse-param-list):
Change kons to val-parser. Always parse keys as symbols, and always
either cons, if there is a val, or just have the key, if there is no
val. Easier to explain and just as correct.
(declare-param-list-header!, declare-key-value-list-header!): Adapt to
key-list and param-list kons change.
("Cache-Control", "Pragma", "Transfer-Encoding", "Accept", "Expect")
("TE"): Likewise, adapt.
("Content-Type"): Param keys are symbols.
This commit is contained in:
Andy Wingo
parent
32de1aa783
commit
0acc595b94
7 changed files with 83 additions and 100 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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"))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue