From 8b2217907edbc9c9e048514115c43f466108fa8b Mon Sep 17 00:00:00 2001 From: sperber Date: Mon, 20 Jan 2003 16:26:26 +0000 Subject: [PATCH] Overhaul RFC822: - reduce RFC822 to four procedures, 2 for reading header bodies into lists of lines, 2 for reading them into concatenated strings - remove lots of Olinism and bugs from rfc822.scm - massage dependent code accordingly, clarifying semantics --- scheme/httpd/cgi-server.scm | 44 ++++++++------- scheme/httpd/core.scm | 5 +- scheme/httpd/logging.scm | 4 ++ scheme/lib/rfc822.scm | 109 ++++++++---------------------------- scheme/packages.scm | 22 +++----- 5 files changed, 62 insertions(+), 122 deletions(-) diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index 6dcc51d..37516b0 100644 --- a/scheme/httpd/cgi-server.scm +++ b/scheme/httpd/cgi-server.scm @@ -238,10 +238,10 @@ (define (cgi-make-response script-port path req) (let* ((headers (read-rfc822-headers script-port)) - (ctype (get-header headers 'content-type)) ; The script headers + (ctype (get-header headers 'content-type)) (loc (get-header headers 'location)) - (stat (extract-status-code-and-text - (get-header-lines headers 'status) req)) + (stat (extract-status-code-and-text (get-header headers 'status) + req)) (extra-headers (delete-headers (delete-headers (delete-headers headers 'content-type) 'location) @@ -268,6 +268,17 @@ (copy-inport->outport script-port out) (close-input-port script-port))))))) +(define (get-header headers tag) + (cond + ((assq tag headers) => cdr) + (else + (http-error (status-code bad-gateway) #f + (string-append "CGI script didn't generate " + (symbol->string tag) + " header"))))) + +(define (delete-headers headers tag) + (alist-delete tag headers)) (define (cgi-make-nph-response script-port) (make-nph-response @@ -279,20 +290,13 @@ (parse-uri loc) (if proto #t #f))) -(define (extract-status-code-and-text stat-lines req) - (cond - ((not (pair? stat-lines)) ; No status header. - (cons (status-code ok) "The idiot CGI script left out the status line.")) - ((null? (cdr stat-lines)) ; One line status header. - (with-fatal-error-handler* - (lambda (c d) - (http-error (status-code bad-gateway) req - "CGI script generated an invalid status header." - (car stat-lines) c)) - (lambda () - (let ((status (string-trim (car stat-lines)))) - (cons (string->number (substring status 0 3)) ; number - (substring/shared status 4)))))) ; text - (else ; Vas ist das? - (http-error (status-code bad-gateway) req - "CGI script generated multi-line status header.")))) \ No newline at end of file +(define (extract-status-code-and-text status req) + (with-fatal-error-handler* + (lambda (c d) + (http-error (status-code bad-gateway) req + "CGI script generated an invalid status header." + status c)) + (lambda () + (let ((status (string-trim status))) + (cons (string->number (substring status 0 3)) ; number + (substring/shared status 4)))))) ; text diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 0663061..bc5cac3 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -245,12 +245,11 @@ (let* ((meth (car elts)) (uri-string (cadr elts)) (url (parse-http-servers-url-fragment uri-string sock options)) - (headers (if (equal? version '(0 . 9)) '() + (headers (if (equal? version '(0 . 9)) + '() (read-rfc822-headers (socket:inport sock))))) (make-request meth uri-string url version headers sock)))))) - - ;;; Parse the URL, but if it begins without the "http://host:port" ;;; prefix, interpolate one from SOCKET. It would be sleazier but ;;; faster if we just computed the default host and port at diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm index a093ab2..ea6a48f 100644 --- a/scheme/httpd/logging.scm +++ b/scheme/httpd/logging.scm @@ -133,6 +133,10 @@ (logging-http-log-port)) (force-output (logging-http-log-port))))))) +(define (get-header headers tag) + (cond + ((assq tag headers) => cdr) + (else "unknown"))) ;; does the logfile rotation on signal USR1 (define (make-logfile-rotator logfile http-log-lock) diff --git a/scheme/lib/rfc822.scm b/scheme/lib/rfc822.scm index cd702bd..90cfb41 100644 --- a/scheme/lib/rfc822.scm +++ b/scheme/lib/rfc822.scm @@ -64,108 +64,45 @@ (lambda (s) (string->symbol (string-map char-upcase s))))) (define (read-rfc822-field . args) + (let ((pair (apply read-rfc822-field-with-line-breaks args))) + (cons (car pair) + (string-concatenate (cdr pair))))) + +(define (read-rfc822-field-with-line-breaks . args) (let-optionals args ((port (current-input-port)) (read-line read-crlf-line)) (let ((line1 (read-line port))) (if (or (eof-object? line1) (zero? (string-length line1)) (string=? line1 "\r\n")) ; In case read-line doesn't trim. - - (values #f #f) ; Blank line or EOF terminates header text. - + (values #f #f) (cond - ((string-index line1 #\:) => ; Find the colon and - (lambda (colon) ; split out field name. + ((string-index line1 #\:) => + (lambda (colon) (let ((name (string->symbol-pref (substring line1 0 colon)))) ;; Read in continuation lines. (let lp ((lines (list (substring line1 (+ colon 1) (string-length line1))))) - (let ((c (peek-char port))) ; Could return EOF. + (let ((c (peek-char port))) ;; RFC822: continuous lines has to start with a space or a htab (if (or (eqv? c #\space) (eqv? c htab)) (lp (cons (read-line port) lines)) (values name (reverse lines)))))))) (else (error "Illegal RFC 822 field syntax." line1))))))) ; No : +(define (make-read-rfc822-headers read-field) + (lambda args + (let-optionals args ((port (current-input-port)) + (read-line read-crlf-line)) + (let lp ((alist '())) + (receive (field val) + (read-rfc822-field port read-line) + (if field + (lp (cons (cons field val) alist)) + alist)))))) -(define (read-rfc822-headers . args) - (let-optionals args ((port (current-input-port)) - (read-line read-crlf-line)) - (let lp ((alist '())) - (receive (field val) (read-rfc822-field port read-line) - (cond (field (cond ((assq field alist) => - (lambda (entry) - (set-cdr! entry (cons val (cdr entry))) - (lp alist))) - (else (lp (cons (list field val) alist))))) - - ;; We are done. Reverse the order of each entry and return. - (else (for-each (lambda (entry) - (set-cdr! entry (reverse (cdr entry)))) - alist) - alist)))))) - -;;; (rejoin-header-lines alist [separator]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Takes a field alist such as is returned by READ-RFC822-HEADERS and -;;; returns an equivalent alist. Each body (string list) in the input alist -;;; is joined into a single list in the output alist. SEPARATOR is the -;;; string used to join these elements together; it defaults to a single -;;; space " ", but can usefully be "\n" or "\r\n". -;;; -;;; To rejoin a single body list, use scsh's STRING-JOIN procedure. - -(define (rejoin-header-lines alist . maybe-separator) - (let-optionals maybe-separator ((sep " ")) - (map (lambda (entry) - (cons (car entry) - (map (lambda (body) (string-join body sep)) - (cdr entry)))) - alist))) - -;;; Given a set of RFC822 headers like this: -;;; From: shivers -;;; To: ziggy, -;;; newts -;;; To: gjs, tk -;;; -;;; We have the following definitions: -;;; (get-header-all hdrs 'to) -> ((" ziggy," " newts") (" gjs, tk")) -;;; - All entries, or #f -;;; (get-header-lines hdrs 'to) -> (" ziggy," " newts") -;;; - All lines of the first entry, or #f. -;;; (get-header hdrs 'to) -> "ziggy,\n newts" -;;; - First entry, with the lines joined together by newlines. - -(define (get-header-all headers name) - (let ((entry (assq name headers))) - (and entry (cdr entry)))) - -(define (get-header-lines headers name) - (let ((entry (assq name headers))) - (and entry - (pair? entry) - (cadr entry)))) - -(define (get-header headers name . maybe-sep) - (let ((entry (assq name headers))) - (and entry - (pair? entry) - (string-join (cadr entry) - (:optional maybe-sep "\n"))))) - -(define (delete-headers headers name) - (fold (lambda (entry rest) - (if (eq? (car entry) name) - rest - (cons entry rest))) - '() - headers)) - -;;; Other desirable functionality -;;; - Unfolding long lines. -;;; - Lexing structured fields. -;;; - Unlexing structured fields into canonical form. -;;; - Parsing and unparsing dates. -;;; - Parsing and unparsing addresses. +(define read-rfc822-headers + (make-read-rfc822-headers read-rfc822-field)) +(define read-rfc822-headers-with-line-breaks + (make-read-rfc822-headers read-rfc822-field-with-line-breaks)) diff --git a/scheme/packages.scm b/scheme/packages.scm index 8c6db36..c5b49cb 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -42,13 +42,9 @@ (define-interface rfc822-interface (export read-rfc822-headers + read-rfc822-headers-with-line-breaks read-rfc822-field - rejoin-header-lines - get-header-all - get-header-lines - get-header - delete-headers - )) + read-rfc822-field-with-line-breaks)) (define-interface uri-interface (export parse-uri @@ -382,13 +378,11 @@ (define-structure rfc822 rfc822-interface (open scheme-with-scsh - receiving ; MV return (RECEIVE and VALUES) - (subset srfi-13 (string-map string-index string-join)) - (subset srfi-1 (fold)) - let-opt ; let-optionals - crlf-io ; read-crlf-line - ascii ; ascii->char - ) + receiving + (subset srfi-13 (string-map string-index string-concatenate)) + let-opt + crlf-io + ascii) (files (lib rfc822))) (define-structure uri uri-interface @@ -656,6 +650,7 @@ (subset srfi-1 (fold-right)) (subset srfi-13 (string-trim)) httpd-responses + httpd-error ) (files (httpd handlers))) @@ -728,6 +723,7 @@ (define-structure httpd-cgi-handlers httpd-cgi-handlers-interface (open scheme-with-scsh + (subset srfi-1 (alist-delete)) (subset srfi-13 (string-prefix? string-index string-trim substring/shared)) rfc822 crlf-io ; WRITE-CRLF