From 167392e1217c0821904ed15ac0f83d5cc77ad5d1 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 21 Sep 2008 23:50:31 +0000 Subject: [PATCH] Provide "TE: trailers" header. Generalize default-header mechanism. Export new procedure CALL-WITH-HTTP-CLIENT-SOCKET. --- v7/src/runtime/http-client.scm | 125 ++++++++++++++++++++++++--------- v7/src/runtime/runtime.pkg | 3 +- 2 files changed, 94 insertions(+), 34 deletions(-) diff --git a/v7/src/runtime/http-client.scm b/v7/src/runtime/http-client.scm index 993afc4ae..eaaf6b4e5 100644 --- a/v7/src/runtime/http-client.scm +++ b/v7/src/runtime/http-client.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: http-client.scm,v 14.9 2008/09/21 07:35:48 cph Exp $ +$Id: http-client.scm,v 14.10 2008/09/21 23:50:28 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -41,14 +41,19 @@ USA. (define (http-client-exchange method uri headers body) (let ((request (http-client-request method uri headers body))) - (let ((port - (let ((authority (uri-authority uri))) - (open-tcp-stream-socket (uri-authority-host authority) - (or (uri-authority-port authority) 80))))) - (write-http-request request port) - (let ((response (read-http-response request port))) - (close-port port) - response)))) + (call-with-http-client-socket uri + (lambda (port) + (write-http-request request port) + (read-http-response request port))))) + +(define (call-with-http-client-socket uri callee) + (let ((port + (let ((authority (uri-authority uri))) + (open-tcp-stream-socket (uri-authority-host authority) + (or (uri-authority-port authority) 80))))) + (let ((value (callee port))) + (close-port port) + value))) (define (http-client-request method uri headers body) (guarantee-absolute-uri uri) @@ -59,29 +64,83 @@ USA. (uri-query uri) (uri-fragment uri)) http-version:1.1 - (add-default-headers headers (uri-authority uri)) + (add-default-headers method uri headers) body)) -(define (add-default-headers headers authority) - (let ((headers (convert-http-headers headers))) - (let ((optional - (lambda (name value) - (if (http-header name headers #f) - '() - (list (make-http-header name value)))))) - `(,(make-http-header 'DATE - (universal-time->global-decoded-time - (get-universal-time))) - ,@(optional 'ACCEPT - `((,(make-mime-type 'APPLICATION 'XHTML+XML)) - (,(make-mime-type 'TEXT 'XHTML) (Q . "0.9")) - (,(make-mime-type 'TEXT 'PLAIN) (Q . "0.5")) - (TEXT (Q . "0.1")))) - ,@(optional 'ACCEPT-CHARSET '((US-ASCII) (ISO-8859-1) (UTF-8))) - ,@(optional 'ACCEPT-ENCODING '((IDENTITY))) - ,@(optional 'ACCEPT-LANGUAGE `((EN-US) (EN (Q . "0.9")))) - ,(make-http-header 'HOST - (cons (uri-authority-host authority) - (uri-authority-port authority))) - ,@(optional 'USER-AGENT default-http-user-agent) - ,@headers)))) +(define (add-default-headers method uri headers) + (let loop + ((ops default-header-ops) + (headers (convert-http-headers headers))) + (if (pair? ops) + (loop (cdr ops) + ((car ops) method uri headers)) + headers))) + +(define default-header-ops + (let () + + (define ((add name make-value) method uri headers) + method uri + (if (http-header name headers #f) + headers + (cons (make-http-header name (make-value)) + headers))) + + (define ((modify name modifier init-value) method uri headers) + method uri + (let ((h (http-header name headers #f))) + (if h + (modifier (http-header-parsed-value h) + (lambda (value) + (replace h + (make-http-header name value) + headers)) + (lambda () headers)) + (modifier init-value + (lambda (value) + (cons (make-http-header name value) headers)) + (lambda () headers))))) + + (define (replace h h* headers) + (let loop ((headers headers)) + (if (pair? headers) + (if (eq? (car headers) h) + (cons h* headers) + (cons (car headers) (loop (cdr headers)))) + '()))) + + (list (add 'ACCEPT + (lambda () + `((,(make-mime-type 'APPLICATION 'XHTML+XML)) + (,(make-mime-type 'TEXT 'XHTML) (Q . "0.9")) + (,(make-mime-type 'TEXT 'PLAIN) (Q . "0.5")) + (TEXT (Q . "0.1"))))) + (add 'ACCEPT-CHARSET (lambda () '((US-ASCII) (ISO-8859-1) (UTF-8)))) + (add 'ACCEPT-ENCODING (lambda () '((IDENTITY)))) + (add 'ACCEPT-LANGUAGE (lambda () `((EN-US) (EN (Q . "0.9"))))) + (modify 'CONNECTION + (lambda (value change no-change) + (if (memq 'TE value) + (no-change) + (change (cons 'TE value)))) + '()) + (add 'DATE + (lambda () + (universal-time->global-decoded-time (get-universal-time)))) + (lambda (method uri headers) + method + (if (http-header 'HOST headers #f) + headers + (cons (make-http-header + 'HOST + (let ((authority (uri-authority uri))) + (cons (uri-authority-host authority) + (uri-authority-port authority)))) + headers))) + (modify 'TE + (lambda (value change no-change) + (if (assq 'TRAILERS value) + (no-change) + (change (cons (list 'TRAILERS) value)))) + '()) + (add 'USER-AGENT (lambda () default-http-user-agent))))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index bec4f4d51..55fc550f5 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.684 2008/09/21 07:35:15 cph Exp $ +$Id: runtime.pkg,v 14.685 2008/09/21 23:50:31 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -5298,6 +5298,7 @@ USA. (files "http-client") (parent (runtime)) (export () + call-with-http-client-socket http-client-exchange http-client-request http-get -- 2.25.1