;;; HTTP messages
-;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 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
header->string
declare-header!
+ declare-opaque-header!
known-header?
header-parser
header-validator
make-chunked-output-port))
-;;; TODO
-;;;
-;;; Look at quality lists with more insight.
-;;; Think about `accept' a bit more.
-;;;
-
-
(define (string->header name)
- "Parse @var{name} to a symbolic header name."
+ "Parse NAME to a symbolic header name."
(string->symbol (string-downcase name)))
(define-record-type <header-decl>
validator
writer
#:key multiple?)
- "Define a parser, validator, and writer for the HTTP header, @var{name}.
-
-@var{parser} should be a procedure that takes a string and returns a
-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."
+ "Declare a parser, validator, and writer for a given header."
(if (and (string? name) parser validator writer)
(let ((decl (make-header-decl name parser validator writer multiple?)))
(hashq-set! *declared-headers* (string->header name) decl)
(error "bad header decl" name parser validator writer multiple?)))
(define (header->string sym)
- "Return the string form for the header named @var{sym}."
+ "Return the string form for the header named 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}."
+ "Return ‘#t’ iff SYM is a known header, with associated
+parsers and serialization procedures."
(and (lookup-header-decl sym) #t))
(define (header-parser sym)
- "Returns a procedure to parse values for the given header."
+ "Return the value parser for headers named SYM. The result is a
+procedure that takes one argument, a string, and returns the parsed
+value. If the header isn't known to Guile, a default parser is returned
+that passes through the string unchanged."
(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."
+ "Return a predicate which returns ‘#t’ if the given value is valid
+for headers named SYM. The default validator for unknown headers
+is ‘string?’."
(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."
+ "Return a procedure that writes values for headers named SYM to a
+port. The resulting procedure takes two arguments: a value and a port.
+The default writer is ‘display’."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-writer decl)
(define *eof* (call-with-input-string "" read))
(define (read-header port)
- "Reads one HTTP header from @var{port}. Returns two values: the header
+ "Reads one HTTP header from PORT. Returns two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.
(string-trim-both line char-set:whitespace (1+ delim)))))))))
(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."
+ "Parse VAL, a string, with the parser registered for the header
+named SYM. Returns the parsed value."
((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}."
+ "Returns a true value iff VAL is a valid Scheme value for the
+header with name SYM."
(if (symbol? sym)
((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 @code{display}."
+ "Write the given header name and value to PORT, using the writer
+from ‘header-writer’."
(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
-ordered alist."
+ "Read the headers of an HTTP message from PORT, returning them
+as an ordered alist."
(let lp ((headers '()))
(call-with-values (lambda () (read-header port))
(lambda (k v)
(lp (acons k v headers)))))))
(define (write-headers headers port)
- "Write the given header alist to @var{port}. Doesn't write the final
-\\r\\n, as the user might want to add another header."
+ "Write the given header alist to PORT. Doesn't write the final
+@samp{\\r\\n}, as the user might want to add another header."
(let lp ((headers headers))
(if (pair? headers)
(begin
(define *known-versions* '())
(define* (parse-http-version str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP version from @var{str}, returning it as a major-minor
-pair. For example, @code{HTTP/1.1} parses as the pair of integers,
-@code{(1 . 1)}."
+ "Parse an HTTP version from STR, returning it as a major-minor
+pair. For example, ‘HTTP/1.1’ parses as the pair of integers,
+‘(1 . 1)’."
(or (let lp ((known *known-versions*))
(and (pair? known)
(if (string= str (caar known) start end)
(bad-header-component 'http-version (substring str start end))))))
(define (write-http-version val port)
- "Write the given major-minor version pair to @var{port}."
+ "Write the given major-minor version pair to PORT."
(display "HTTP/" port)
(display (car val) port)
(display #\. port)
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP method from @var{str}. The result is an upper-case
-symbol, like @code{GET}."
+ "Parse an HTTP method from STR. The result is an upper-case
+symbol, like ‘GET’."
(cond
((string= str "GET" start end) 'GET)
((string= str "HEAD" start end) 'HEAD)
(bad-request "Invalid URI: ~a" (substring str start end))))))
(define (read-request-line port)
- "Read the first line of an HTTP request from @var{port}, returning
+ "Read the first line of an HTTP request from PORT, returning
three values: the method, the URI, and the version."
(let* ((line (read-line* port))
(d0 (string-index line char-set:whitespace)) ; "delimiter zero"
(display (uri-query uri) port))))
(define (write-request-line method uri version port)
- "Write the first line of an HTTP request to @var{port}."
+ "Write the first line of an HTTP request to PORT."
(display method port)
(display #\space port)
(let ((path (uri-path uri))
(display "\r\n" port))
(define (read-response-line port)
- "Read the first line of an HTTP response from @var{port}, returning
+ "Read the first line of an HTTP response from PORT, returning
three values: the HTTP version, the response code, and the \"reason
phrase\"."
(let* ((line (read-line* port))
(bad-response "Bad Response-Line: ~s" line))))
(define (write-response-line version code reason-phrase port)
- "Write the first line of an HTTP response to @var{port}."
+ "Write the first line of an HTTP response to PORT."
(write-http-version version port)
(display #\space port)
(display code port)
;; emacs: (put 'declare-header! 'scheme-indent-function 1)
;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
(define (declare-opaque-header! name)
+ "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."
(declare-header! name
parse-opaque-string validate-opaque-string write-opaque-string))
(define (declare-uri-header! name)
(declare-header! name
(lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
+ (@@ (web uri) absolute-uri?)
+ write-uri))
+
+;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
+(define (declare-relative-uri-header! name)
+ (declare-header! name
+ (lambda (str)
+ (or ((@@ (web uri) string->uri*) str)
+ (bad-header-component 'uri str)))
uri?
write-uri))
;; Connection = "Connection" ":" 1#(connection-token)
;; connection-token = token
;; e.g.
-;; Connection: close, foo-header
+;; Connection: close, Foo-Header
;;
-(declare-header-list-header! "Connection")
+(declare-header! "Connection"
+ split-header-names
+ list-of-header-names?
+ (lambda (val port)
+ (write-list val port
+ (lambda (x port)
+ (display (if (eq? x 'close)
+ "close"
+ (header->string x))
+ port))
+ ", ")))
;; Date = "Date" ":" HTTP-date
;; e.g.
;; Content-Location = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Content-Location")
+(declare-relative-uri-header! "Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
;; Referer = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Referer")
+(declare-relative-uri-header! "Referer")
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
(define* (make-chunked-input-port port #:key (keep-alive? #f))
"Returns a new port which translates HTTP chunked transfer encoded
-data from @var{port} into a non-encoded format. Returns eof when it has
-read the final chunk from @var{port}. This does not necessarily mean
-that there is no more data on @var{port}. When the returned port is
-closed it will also close @var{port}, unless the KEEP-ALIVE? is true."
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
(define (next-chunk)
(read-chunk port))
(define finished? #f)
(define* (make-chunked-output-port port #:key (keep-alive? #f))
"Returns a new port which translates non-encoded data into a HTTP
-chunked transfer encoded data and writes this to @var{port}. Data
+chunked transfer encoded data and writes this to PORT. Data
written to this port is buffered until the port is flushed, at which
point it is all sent as one chunk. Take care to close the port when
done, as it will output the remaining data, and encode the final zero
-chunk. When the port is closed it will also close @var{port}, unless
+chunk. When the port is closed it will also close PORT, unless
KEEP-ALIVE? is true."
(define (q-for-each f q)
(while (not (q-empty? q))
HCoop / bpt / guile.git / blobdiff