1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00

(web http): don't expose header-decl objects

* module/web/http.scm: Change to not expose the header-decl objects,
  instead exposing header-parse, header-validator, header-writer et al.
  Explaining header decls in the manual was too complicated.
  (string->header, header->string): New helpers.
  (<header-decl>): Remove the `sym' field.
  (declare-header!): Adapt to header-decl change, and use
  string->header.
  (known-header?, header-parser, header-validator, header-writer): New
  procedures.

  Adapt to use the new procedures internally.
This commit is contained in:
Andy Wingo 2011-01-08 11:40:20 -08:00
parent be1be3e597
commit 7118eccd72

View file

@ -36,16 +36,14 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (web uri)
#:export (header-decl?
make-header-decl
header-decl-sym
header-decl-name
header-decl-multiple?
header-decl-parser
header-decl-validator
header-decl-writer
lookup-header-decl
#:export (string->header
header->string
declare-header!
known-header?
header-parser
header-validator
header-writer
read-header
parse-header
@ -72,19 +70,25 @@
;;;
(define (string->header name)
"Parse @var{name} to a symbolic header name."
(string->symbol (string-downcase name)))
(define-record-type <header-decl>
(make-header-decl sym name multiple? parser validator writer)
(make-header-decl name parser validator writer multiple?)
header-decl?
(sym header-decl-sym)
(name header-decl-name)
(multiple? header-decl-multiple?)
(parser header-decl-parser)
(validator header-decl-validator)
(writer header-decl-writer))
(writer header-decl-writer)
(multiple? header-decl-multiple?))
;; sym -> header
(define *declared-headers* (make-hash-table))
(define (lookup-header-decl sym)
(hashq-ref *declared-headers* sym))
(define* (declare-header! name
parser
validator
@ -97,12 +101,44 @@ Scheme value. @var{validator} is a predicate for whether the given
Scheme value is valid for this header. @var{writer} takes a value and a
port, and writes the value to the port."
(if (and (string? name) parser validator writer)
(let* ((sym (string->symbol (string-downcase name)))
(decl (make-header-decl sym name
multiple? parser validator writer)))
(hashq-set! *declared-headers* sym decl)
(let ((decl (make-header-decl name parser validator writer multiple?)))
(hashq-set! *declared-headers* (string->header name) decl)
decl)
(error "bad header decl" name multiple? parser validator writer)))
(error "bad header decl" name parser validator writer multiple?)))
(define (header->string sym)
"Return the string form for the header named @var{sym}."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-name decl)
(string-titlecase (symbol->string sym)))))
(define (known-header? sym)
"Return @code{#t} if there are parsers and writers registered for this
header, otherwise @code{#f}."
(and (lookup-header-decl sym) #t))
(define (header-parser sym)
"Returns a procedure to parse values for the given header."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-parser decl)
(lambda (x) x))))
(define (header-validator sym)
"Returns a procedure to validate values for the given header."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-validator decl)
string?)))
(define (header-writer sym)
"Returns a procedure to write values for the given header to a given
port."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-writer decl)
display)))
(define (read-line* port)
(let* ((pair (%read-line port))
@ -143,8 +179,7 @@ body was reached (i.e., a blank line)."
(values *eof* *eof*)
(let* ((delim (or (string-index line #\:)
(bad-header '%read line)))
(sym (string->symbol
(string-downcase! (substring/copy line 0 delim)))))
(sym (string->header (substring line 0 delim))))
(values
sym
(parse-header
@ -153,42 +188,29 @@ body was reached (i.e., a blank line)."
port
(string-trim-both line char-whitespace? (1+ delim)))))))))
(define (lookup-header-decl sym)
"Return the @var{header-decl} object registered for the given
@var{sym}, which should be a symbol."
(hashq-ref *declared-headers* sym))
(define (parse-header sym val)
"Parse @var{val}, a string, with the parser registered for the header
named @var{sym}.
Returns the parsed value. If a parser was not found, the value is
returned as a string."
(let ((decl (lookup-header-decl sym)))
(if decl
((header-decl-parser decl) val)
val)))
((header-parser sym) val))
(define (valid-header? sym val)
"Returns a true value iff @var{val} is a valid Scheme value for the
header with name @var{sym}."
(if (symbol? sym)
(let ((decl (lookup-header-decl sym)))
(or (not decl)
((header-decl-validator decl) val)))
((header-validator sym) val)
(error "header name not a symbol" sym)))
(define (write-header sym val port)
"Writes the given header name and value to @var{port}. If @var{sym}
is a known header, uses the specific writer registered for that header.
Otherwise the value is written using @var{display}."
(let ((decl (lookup-header-decl sym)))
(if decl
(display (header-decl-name decl) port)
(display (string-titlecase (symbol->string sym)) port))
(display ": " port)
((if decl (header-decl-writer decl) display) val port)
(display "\r\n" port)))
(display (header->string sym) port)
(display ": " port)
((header-writer sym) val port)
(display "\r\n" port))
(define (read-headers port)
"Read an HTTP message from @var{port}, returning the headers as an
@ -267,9 +289,7 @@ ordered alist."
(write-list val port display ", "))
(define (split-header-names str)
(map (lambda (f)
(string->symbol (string-downcase f)))
(split-and-trim str)))
(map string->header (split-and-trim str)))
(define (list-of-header-names? val)
(list-of? val symbol?))
@ -277,10 +297,7 @@ ordered alist."
(define (write-header-list val port)
(write-list val port
(lambda (x port)
(display (or (and=> (lookup-header-decl x)
header-decl-name)
(string-titlecase (symbol->string x)))
port))
(display (header->string x) port))
", "))
(define (collect-escaped-string from start len escapes)