scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
This commit is contained in:
sperber 2003-01-20 16:26:26 +00:00
parent ef7a21b729
commit 8b2217907e
5 changed files with 62 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
scheme/httpd/cgi-server.scm
View File

@ -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."))))
(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

5
scheme/httpd/core.scm
View File

@ -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

4
scheme/httpd/logging.scm
View File

@ -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)

109
scheme/lib/rfc822.scm
View File

@ -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))

22
scheme/packages.scm
View File

@ -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