X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/47153f29b02cee6324aec523cfa44b48e1cb29b9..b4fa6cc90961c87b28e26b469863f19a1be26ce2:/module/web/http.scm diff --git a/module/web/http.scm b/module/web/http.scm index ad9063cd2..c79d57d78 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -34,11 +34,15 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (ice-9 rdelim) + #:use-module (ice-9 q) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) #:use-module (web uri) #:export (string->header header->string declare-header! + declare-opaque-header! known-header? header-parser header-validator @@ -59,18 +63,14 @@ read-request-line write-request-line read-response-line - write-response-line)) + write-response-line - -;;; TODO -;;; -;;; Look at quality lists with more insight. -;;; Think about `accept' a bit more. -;;; + make-chunked-input-port + make-chunked-output-port)) (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 @@ -93,12 +93,7 @@ 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) @@ -106,34 +101,40 @@ port, and writes the value to the port." (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) @@ -166,7 +167,7 @@ port." (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. @@ -188,32 +189,28 @@ body was reached (i.e., a blank line)." (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) @@ -222,8 +219,8 @@ ordered alist." (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 @@ -240,7 +237,22 @@ ordered alist." (define (bad-header sym val) (throw 'bad-header sym val)) (define (bad-header-component sym val) - (throw 'bad-header sym val)) + (throw 'bad-header-component sym val)) + +(define (bad-header-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header: ~a\n" (header->string sym) val)) + (_ (default-printer))) + args)) +(define (bad-header-component-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header component: ~a\n" sym val)) + (_ (default-printer))) + args)) +(set-exception-printer! 'bad-header bad-header-printer) +(set-exception-printer! 'bad-header-component bad-header-component-printer) (define (parse-opaque-string str) str) @@ -959,9 +971,9 @@ ordered alist." (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) @@ -976,7 +988,7 @@ pair. For example, @code{HTTP/1.1} parses as the pair of integers, (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) @@ -997,8 +1009,8 @@ pair. For example, @code{HTTP/1.1} parses as the pair of integers, ;; 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) @@ -1030,7 +1042,7 @@ not have to have a scheme or host name. The result is a URI object." (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" @@ -1071,7 +1083,7 @@ three values: the method, the URI, and the version." (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)) @@ -1091,7 +1103,7 @@ three values: the method, the URI, and the version." (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)) @@ -1106,7 +1118,7 @@ phrase\"." (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) @@ -1124,6 +1136,8 @@ phrase\"." ;; 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)) @@ -1161,6 +1175,15 @@ phrase\"." (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)) @@ -1277,9 +1300,19 @@ phrase\"." ;; 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. @@ -1416,7 +1449,7 @@ phrase\"." ;; Content-Location = ( absoluteURI | relativeURI ) ;; -(declare-uri-header! "Content-Location") +(declare-relative-uri-header! "Content-Location") ;; Content-MD5 = ;; @@ -1705,7 +1738,7 @@ phrase\"." ;; Referer = ( absoluteURI | relativeURI ) ;; -(declare-uri-header! "Referer") +(declare-relative-uri-header! "Referer") ;; TE = #( t-codings ) ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) @@ -1784,3 +1817,99 @@ phrase\"." ;; WWW-Authenticate = 1#challenge ;; (declare-challenge-list-header! "WWW-Authenticate") + + +;; Chunked Responses +(define (read-chunk-header port) + (let* ((str (read-line port)) + (extension-start (string-index str (lambda (c) (or (char=? c #\;) + (char=? c #\return))))) + (size (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))) + size)) + +(define (read-chunk port) + (let ((size (read-chunk-header port))) + (read-chunk-body port size))) + +(define (read-chunk-body port size) + (let ((bv (get-bytevector-n port size))) + (get-u8 port) ; CR + (get-u8 port) ; LF + bv)) + +(define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +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 (close) + (unless keep-alive? + (close-port port))) + (define buffer #vu8()) + (define buffer-size 0) + (define buffer-pointer 0) + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((<= to-read (- buffer-size buffer-pointer)) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + to-read) + (set! buffer-pointer (+ buffer-pointer to-read)) + (loop 0 (+ num-read to-read))) + (else + (let ((n (- buffer-size buffer-pointer))) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + n) + (set! buffer (next-chunk)) + (set! buffer-pointer 0) + (set! buffer-size (bytevector-length buffer)) + (set! finished? (= buffer-size 0)) + (loop (- to-read n) + (+ num-read n)))))) + (loop to-read 0)) + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + +(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 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 PORT, unless +KEEP-ALIVE? is true." + (define (q-for-each f q) + (while (not (q-empty? q)) + (f (deq! q)))) + (define queue (make-q)) + (define (put-char c) + (enq! queue c)) + (define (put-string s) + (string-for-each (lambda (c) (enq! queue c)) + s)) + (define (flush) + ;; It is important that we do _not_ write a chunk if the queue is + ;; empty, since it will be treated as the final chunk. + (unless (q-empty? queue) + (let ((len (q-length queue))) + (display (number->string len 16) port) + (display "\r\n" port) + (q-for-each (lambda (elem) (write-char elem port)) + queue) + (display "\r\n" port)))) + (define (close) + (flush) + (display "0\r\n" port) + (force-output port) + (unless keep-alive? + (close-port port))) + (make-soft-port (vector put-char put-string flush #f close) "w"))