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

Adopt proper RFC terminology: 

"reply" -> "response"
"reply code" -> "status code"
This commit is contained in:
sperber 2002-08-26 09:59:14 +00:00
parent d1438eb4a8
commit 6f7cd467f1
13 changed files with 170 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/httpd/access-control.scm
View File

@ -32,7 +32,7 @@
(if (eq? (if (eq?
(control (host-info (socket-remote-address (request:socket req)))) (control (host-info (socket-remote-address (request:socket req))))
'deny) 'deny)
(http-error http-reply/forbidden req) (http-error http-status/forbidden req)
(ph path req)))) (ph path req))))
(define (address->list address) (define (address->list address)

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

@ -14,7 +14,7 @@
;;; SWITCH conditional ;;; SWITCH conditional
;;; RFC822 header parsing ;;; RFC822 header parsing
;;; HTTP request record structure ;;; HTTP request record structure
;;; HTTP-ERROR & reply codes ;;; HTTP-ERROR & status codes
;;; Basic path handler support (for ncsa-handler) ;;; Basic path handler support (for ncsa-handler)
;;; PROBLEMS: ;;; PROBLEMS:
@ -68,15 +68,15 @@
;;; - The CGI script is run with stdin hooked up to the socket. If it's going ;;; - The CGI script is run with stdin hooked up to the socket. If it's going
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth. ;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
;;; - A bunch of env vars are set; see below. ;;; - A bunch of env vars are set; see below.
;;; - If the script begins with "nph-" its output is the entire reply. ;;; - If the script begins with "nph-" its output is the entire response.
;;; Otherwise, it replies to the server, we peel off a little header ;;; Otherwise, it replies to the server, we peel off a little header
;;; that is used to construct the real header for the reply. ;;; that is used to construct the real header for the response.
;;; See the "spec" for further details. (URL above). ;;; See the "spec" for further details. (URL above).
;;; ;;;
;;; The "spec" also talks about PUT, but when I tried this on a dummy script, ;;; The "spec" also talks about PUT, but when I tried this on a dummy script,
;;; the NSCA httpd server generated buggy output. So I am only implementing ;;; the NSCA httpd server generated buggy output. So I am only implementing
;;; the POST and GET ops; any other op generates a "405 Method not allowed" ;;; the POST and GET ops; any other op generates a "405 Method not allowed"
;;; reply. ;;; response.
;;; Parameters ;;; Parameters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -103,7 +103,7 @@
(let* ((prog (car path)) (let* ((prog (car path))
(filename (or (dotdot-check bin-dir (list prog)) (filename (or (dotdot-check bin-dir (list prog))
(http-error http-reply/bad-request req (http-error http-status/bad-request req
(format #f "CGI scripts may not contain \"..\" elements.")))) (format #f "CGI scripts may not contain \"..\" elements."))))
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ? (nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
@ -129,15 +129,15 @@
(if nph? (if nph?
(let ((stat (wait (fork doit)))) (let ((stat (wait (fork doit))))
(if (not (zero? stat)) (if (not (zero? stat))
(http-error http-reply/bad-request req (http-error http-status/bad-request req
(format #f "Could not execute CGI script ~a." (format #f "Could not execute CGI script ~a."
filename)) filename))
stat)) stat))
(cgi-send-reply (run/port* doit) req))) (cgi-send-response (run/port* doit) req)))
(else (http-error http-reply/method-not-allowed req))))) (else (http-error http-status/method-not-allowed req)))))
(http-error http-reply/bad-request req "Empty CGI script")))))) (http-error http-status/bad-request req "Empty CGI script"))))))
(define (split-and-decode-search-spec s) (define (split-and-decode-search-spec s)
@ -219,7 +219,7 @@
(cl-len (string-length cl))) (cl-len (string-length cl)))
(if first-digit (if first-digit
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len))) `(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
(http-error http-reply/bad-request (http-error http-status/bad-request
req req
"Illegal Content-length: header."))))) "Illegal Content-length: header.")))))
@ -238,10 +238,10 @@
;;; Script's output for request REQ is available on SCRIPT-PORT. ;;; Script's output for request REQ is available on SCRIPT-PORT.
;;; The script isn't an "nph-" script, so we read the reply, and mutate ;;; The script isn't an "nph-" script, so we read the response, and mutate
;;; it into a real HTTP reply, which we then send back to the HTTP client. ;;; it into a real HTTP response, which we then send back to the HTTP client.
(define (cgi-send-reply script-port req) (define (cgi-send-response script-port req)
(let* ((headers (read-rfc822-headers script-port)) (let* ((headers (read-rfc822-headers script-port))
(ctype (get-header headers 'content-type)) ; The script headers (ctype (get-header headers 'content-type)) ; The script headers
(loc (get-header headers 'location)) (loc (get-header headers 'location))
@ -252,13 +252,13 @@
((null? (cdr stat-lines)) ; One line status header. ((null? (cdr stat-lines)) ; One line status header.
(car stat-lines)) (car stat-lines))
(else ; Vas ist das? (else ; Vas ist das?
(http-error http-reply/internal-error req (http-error http-status/internal-error req
"CGI script generated multi-line status header"))))) "CGI script generated multi-line status header")))))
(out (current-output-port))) (out (current-output-port)))
(http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers) (http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers)
;; Send the reply header back to the client ;; Send the response header back to the client
;; (unless it's a headerless HTTP 0.9 reply). ;; (unless it's a headerless HTTP 0.9 response).
(if (not (v0.9-request? req)) (if (not (v0.9-request? req))
(begin (begin
(format out "HTTP/1.0 ~a\r~%" stat) (format out "HTTP/1.0 ~a\r~%" stat)
@ -267,7 +267,7 @@
(write-crlf out))) (write-crlf out)))
(http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%" (request:method req)) (http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%" (request:method req))
;; Copy the reply body back to the client and close the script port ;; Copy the response body back to the client and close the script port
;; (unless it's a bodiless HEAD transaction). ;; (unless it's a bodiless HEAD transaction).
(if (not (string=? (request:method req) "HEAD")) (if (not (string=? (request:method req) "HEAD"))
(begin (begin

52
scheme/httpd/core.scm
View File

@ -102,7 +102,7 @@
;;; Read, parse, and handle a single http request. The only thing that makes ;;; Read, parse, and handle a single http request. The only thing that makes
;;; this complicated is handling errors -- as a server, we can't just let the ;;; this complicated is handling errors -- as a server, we can't just let the
;;; standard error handlers toss us into a breakpoint. We have to catch the ;;; standard error handlers toss us into a breakpoint. We have to catch the
;;; error, send an error reply back to the client if we can, and then keep ;;; error, send an error response back to the client if we can, and then keep
;;; on trucking. This means using the S48's condition system to catch and ;;; on trucking. This means using the S48's condition system to catch and
;;; handle the various errors, which introduces a major point of R4RS ;;; handle the various errors, which introduces a major point of R4RS
;;; incompatibiliy -- R4RS has no exception system. So if you were to port ;;; incompatibiliy -- R4RS has no exception system. So if you were to port
@ -111,7 +111,7 @@
(define (process-toplevel-request sock host-address options) (define (process-toplevel-request sock host-address options)
;; This top-level error-handler catches *all* uncaught errors and warnings. ;; This top-level error-handler catches *all* uncaught errors and warnings.
;; If the error condition is a reportable HTTP error, we send a reply back ;; If the error condition is a reportable HTTP error, we send a response back
;; to the client. In any event, we abort the transaction, and return from ;; to the client. In any event, we abort the transaction, and return from
;; PROCESS-TOPLEVEL-REQUEST. ;; PROCESS-TOPLEVEL-REQUEST.
;; ;;
@ -145,15 +145,15 @@
c) c)
(cond (cond
((http-error? c) ((http-error? c)
(apply (lambda (reply-code req . args) (apply (lambda (status-code req . args)
(values req (values req
(apply make-http-error-response (apply make-http-error-response
reply-code req status-code req
args))) args)))
(condition-stuff c))) (condition-stuff c)))
((fatal-syntax-error? c) ((fatal-syntax-error? c)
(values #f (values #f
(apply make-http-error-response http-reply/bad-request (apply make-http-error-response http-status/bad-request
#f ; No request yet. #f ; No request yet.
"Request parsing error -- report to client maintainer." "Request parsing error -- report to client maintainer."
(condition-stuff c)))) (condition-stuff c))))
@ -167,7 +167,7 @@
(values req response))))) (values req response)))))
(lambda (req response) (lambda (req response)
(send-http-response response (socket:outport sock) options) (send-http-response response (socket:outport sock) options)
(http-log req http-reply/ok)))))) (http-log req http-status/ok))))))
;;;; HTTP request parsing ;;;; HTTP request parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -302,9 +302,9 @@
(write-crlf port)) (write-crlf port))
headers)) headers))
;;; (make-http-error-response reply-code req [message . extras]) ;;; (make-http-error-response status-code req [message . extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Take an http-error condition, and format it into a reply to the client. ;;; Take an http-error condition, and format it into a response to the client.
;;; ;;;
;;; As a special case, request REQ is allowed to be #f, meaning we haven't ;;; As a special case, request REQ is allowed to be #f, meaning we haven't
;;; even had a chance to parse and construct the request. This is only used ;;; even had a chance to parse and construct the request. This is only used
@ -316,38 +316,38 @@
;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll ;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll
;;; leave it in to play it safe.) ;;; leave it in to play it safe.)
(define (make-http-error-response reply-code req . args) (define (make-http-error-response status-code req . args)
(ignore-errors (ignore-errors
(lambda () ; Ignore errors -- see note above. (lambda () ; Ignore errors -- see note above.
(apply really-make-http-error-response reply-code req args)))) (apply really-make-http-error-response status-code req args))))
(define (really-make-http-error-response reply-code req . args) (define (really-make-http-error-response status-code req . args)
(http-log req reply-code) (http-log req status-code)
(let* ((message (and (pair? args) (car args))) (let* ((message (and (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '())) (extras (if (pair? args) (cdr args) '()))
(generic-title (lambda (port) (generic-title (lambda (port)
(title-html port (title-html port
(reply-code->text reply-code)))) (status-code->text status-code))))
(close-html (lambda (port) (close-html (lambda (port)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras) (for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" port))) (write-string "</BODY>\n" port)))
(create-response (create-response
(lambda (headers writer-proc) (lambda (headers writer-proc)
(make-response reply-code (make-response status-code
(reply-code->text reply-code) (status-code->text status-code)
(time) (time)
"text/html" "text/html"
headers headers
(make-writer-body writer-proc))))) (make-writer-body writer-proc)))))
(cond (cond
;; This error reply requires two args: message is the new URI: field, ;; This error response requires two args: message is the new URI: field,
;; and the first EXTRA is the older Location: field. ;; and the first EXTRA is the older Location: field.
((or (= reply-code http-reply/moved-temp) ((or (= status-code http-status/moved-temp)
(= reply-code http-reply/moved-perm)) (= status-code http-status/moved-perm))
(create-response (create-response
(list (cons 'uri message) (list (cons 'uri message)
(cons 'location (car extras))) (cons 'location (car extras)))
@ -355,11 +355,11 @@
(title-html port "Document moved") (title-html port "Document moved")
(format port (format port
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%" "This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
(if (= reply-code http-reply/moved-temp) "temporarily" "permanently") (if (= status-code http-status/moved-temp) "temporarily" "permanently")
message) message)
(close-html port)))) (close-html port))))
((= reply-code http-reply/bad-request) ((= status-code http-status/bad-request)
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
@ -369,7 +369,7 @@
(if message (format port "<BR>~%Reason: ~A~%" message)) (if message (format port "<BR>~%Reason: ~A~%" message))
(close-html port)))) (close-html port))))
((= reply-code http-reply/unauthorized) ((= status-code http-status/unauthorized)
(create-response (create-response
(list (cons 'WWW-Authenticate message)) ; Vas is das? (list (cons 'WWW-Authenticate message)) ; Vas is das?
(lambda (port options) (lambda (port options)
@ -379,7 +379,7 @@
(if message (format port "~a~%" message)) (if message (format port "~a~%" message))
(close-html port)))) (close-html port))))
((= reply-code http-reply/forbidden) ((= status-code http-status/forbidden)
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
@ -391,7 +391,7 @@
(if message (format port "<P>~%~a~%" message)) (if message (format port "<P>~%~a~%" message))
(close-html port)))) (close-html port))))
((= reply-code http-reply/not-found) ((= status-code http-status/not-found)
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
@ -402,7 +402,7 @@
(if message (format port "<P>~%~a~%" message)) (if message (format port "<P>~%~a~%" message))
(close-html port)))) (close-html port))))
((= reply-code http-reply/internal-error) ((= status-code http-status/internal-error)
(http-syslog (syslog-level error) "internal-error: ~A" message) (http-syslog (syslog-level error) "internal-error: ~A" message)
(create-response (create-response
'() '()
@ -417,7 +417,7 @@ the error, and time it occured.~%"
(if message (format port "<P>~%~a~%" message)) (if message (format port "<P>~%~a~%" message))
(close-html port)))) (close-html port))))
((= reply-code http-reply/not-implemented) ((= status-code http-status/not-implemented)
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
@ -429,7 +429,7 @@ the requested method (~A).~%"
(close-html port)))) (close-html port))))
(else (else
(http-syslog (syslog-level info) "Skipping unhandled reply code ~A.~%" reply-code) (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code)
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)

8
scheme/httpd/error.scm
View File

@ -11,16 +11,16 @@
;;; HTTP error condition ;;; HTTP error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define a sub-type of the S48 error condition, the HTTP error condition. ;;; Define a sub-type of the S48 error condition, the HTTP error condition.
;;; An HTTP error is one that corresponds to one of the HTTP error reply ;;; An HTTP error is one that corresponds to one of the HTTP error response
;;; codes, so you can reliably use an HTTP error condition to construct an ;;; codes, so you can reliably use an HTTP error condition to construct an
;;; error reply message to send back to the HTTP client. ;;; error response message to send back to the HTTP client.
(define-condition-type 'http-error '(error)) (define-condition-type 'http-error '(error))
(define http-error? (condition-predicate 'http-error)) (define http-error? (condition-predicate 'http-error))
(define (http-error error-code req . args) (define (http-error status-code req . args)
(apply signal 'http-error error-code req args)) (apply signal 'http-error status-code req args))
;;; Syntax error condition ;;; Syntax error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

38
scheme/httpd/file-dir-handler.scm
View File

@ -22,7 +22,7 @@
(cdr path) (cdr path)
file-serve-response file-serve-response
req) req)
(make-http-error-response http-reply/bad-request (make-http-error-response http-status/bad-request
req req
"Path contains no home directory.")))) "Path contains no home directory."))))
@ -69,11 +69,11 @@
req))) req)))
;;; The null path handler -- handles nothing, sends back an error reply. ;;; The null path handler -- handles nothing, sends back an error response.
;;; Can be useful as the default in table-driven path handlers. ;;; Can be useful as the default in table-driven path handlers.
(define (null-path-handler path req) (define (null-path-handler path req)
(make-http-error-response http-reply/not-found req)) (make-http-error-response http-status/not-found req))
;;;; Support procs for the path handlers ;;;; Support procs for the path handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -109,13 +109,13 @@
(define (make-rooted-file-path-response root file-path file-serve-response req) (define (make-rooted-file-path-response root file-path file-serve-response req)
(if (http-url:search (request:url req)) (if (http-url:search (request:url req))
(make-http-error-response http-reply/bad-request req (make-http-error-response http-status/bad-request req
"Indexed search not provided for this URL.") "Indexed search not provided for this URL.")
(cond ((dotdot-check root file-path) => (cond ((dotdot-check root file-path) =>
(lambda (fname) (lambda (fname)
(file-serve-response fname file-path req))) (file-serve-response fname file-path req)))
(else (else
(make-http-error-response http-reply/bad-request req (make-http-error-response http-status/bad-request req
"URL contains unresolvable ..'s."))))) "URL contains unresolvable ..'s.")))))
@ -125,9 +125,9 @@
(with-errno-handler (with-errno-handler
((errno packet) ((errno packet)
((errno/noent) ((errno/noent)
(http-error http-reply/not-found req)) (http-error http-status/not-found req))
((errno/acces) ((errno/acces)
(http-error http-reply/forbidden req))) (http-error http-status/forbidden req)))
(file-info fname #t))) (file-info fname #t)))
;;; A basic file request handler -- ship the dude the file. No fancy path ;;; A basic file request handler -- ship the dude the file. No fancy path
@ -150,14 +150,14 @@
((directory) ; Send back a redirection "foo" -> "foo/" ((directory) ; Send back a redirection "foo" -> "foo/"
(make-http-error-response (make-http-error-response
http-reply/moved-perm req http-status/moved-perm req
(string-append (request:uri req) "/") (string-append (request:uri req) "/")
(string-append (http-url->string (request:url req)) (string-append (http-url->string (request:url req))
"/"))) "/")))
(else (make-http-error-response http-reply/forbidden req))))) (else (make-http-error-response http-status/forbidden req)))))
(else (make-http-error-response http-reply/method-not-allowed req)))))) (else (make-http-error-response http-status/method-not-allowed req))))))
(define (directory-index-serve-response fname file-path req) (define (directory-index-serve-response fname file-path req)
(file-serve-response (string-append fname "index.html") file-path req)) (file-serve-response (string-append fname "index.html") file-path req))
@ -347,10 +347,10 @@
(if (not (eq? 'directory (if (not (eq? 'directory
(file-info:type (file-info fname #t)))) (file-info:type (file-info fname #t))))
(make-http-error-response http-reply/forbidden req) (make-http-error-response http-status/forbidden req)
(make-response (make-response
http-reply/ok http-status/ok
(reply-code->text http-reply/ok) (status-code->text http-status/ok)
(time) (time)
"text/html" "text/html"
'() '()
@ -392,7 +392,7 @@
(emit-tag port 'hr) (emit-tag port 'hr)
(format port "~d files" n-files)))))))))))) (format port "~d files" n-files))))))))))))
(else (else
(make-http-error-response http-reply/method-not-allowed req))))) (make-http-error-response http-status/method-not-allowed req)))))
(define (index-or-directory-serve-response fname file-path req) (define (index-or-directory-serve-response fname file-path req)
(let ((index-fname (string-append fname "index.html"))) (let ((index-fname (string-append fname "index.html")))
@ -404,11 +404,11 @@
(file-serve-or-dir-response fname file-path req (file-serve-or-dir-response fname file-path req
index-or-directory-serve-response)) index-or-directory-serve-response))
;;; Look up user's home directory, generating an HTTP error reply if you lose. ;;; Look up user's home directory, generating an HTTP error response if you lose.
(define (http-homedir username req) (define (http-homedir username req)
(with-fatal-error-handler (lambda (c decline) (with-fatal-error-handler (lambda (c decline)
(apply http-error http-reply/bad-request req (apply http-error http-status/bad-request req
"Couldn't find user's home directory." "Couldn't find user's home directory."
(condition-stuff c))) (condition-stuff c)))
@ -417,11 +417,11 @@
(define (send-file-response filename info req) (define (send-file-response filename info req)
(if (file-not-readable? filename) ; #### double stats are no good (if (file-not-readable? filename) ; #### double stats are no good
(make-http-error-response http-reply/not-found req) (make-http-error-response http-status/not-found req)
(receive (stripped-filename content-encoding) (receive (stripped-filename content-encoding)
(file-extension->content-encoding filename) (file-extension->content-encoding filename)
(make-response http-reply/ok (make-response http-status/ok
(reply-code->text http-reply/ok) (status-code->text http-status/ok)
(time) (time)
(file-extension->content-type stripped-filename) (file-extension->content-type stripped-filename)
(append (if content-encoding (append (if content-encoding

16
scheme/httpd/info-gateway.scm
View File

@ -136,7 +136,7 @@
(lambda (c decline) (lambda (c decline)
(cond (cond
((info-gateway-error? c) ((info-gateway-error? c)
(apply http-error http-reply/internal-error req (apply http-error http-status/internal-error req
(condition-stuff c))) (condition-stuff c)))
((http-error? c) ((http-error? c)
(apply http-error (car (condition-stuff c)) req (apply http-error (car (condition-stuff c)) req
@ -146,7 +146,7 @@
(if (not (v0.9-request? req)) (if (not (v0.9-request? req))
(begin (begin
(begin-http-header #t http-reply/ok) (begin-http-header #t http-status/ok)
(write-string "Content-type: text/html\r\n") (write-string "Content-type: text/html\r\n")
(write-string "\r\n"))) (write-string "\r\n")))
@ -158,7 +158,7 @@
(with-tag #t address () (with-tag #t address ()
(write-string address)))) (write-string address))))
(else (http-error http-reply/method-not-allowed req))))))) (else (http-error http-status/method-not-allowed req)))))))
(define split-header-line (define split-header-line
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)"))) (let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))
@ -508,7 +508,7 @@
(if (eof-object? line) (if (eof-object? line)
(info-gateway-error "invalid info file")) (info-gateway-error "invalid info file"))
(if (regexp-exec node-epilogue-regexp line) (if (regexp-exec node-epilogue-regexp line)
(http-error http-reply/not-found #f "node not found")) (http-error http-status/not-found #f "node not found"))
(receive (entry-node file seek) (parse-tag line) (receive (entry-node file seek) (parse-tag line)
(if (string=? node entry-node) (if (string=? node entry-node)
(cons file seek) (cons file seek)
@ -517,7 +517,7 @@
(define (find-indirection-entry seek-pos indirection-table) (define (find-indirection-entry seek-pos indirection-table)
(let loop ((table indirection-table)) (let loop ((table indirection-table))
(if (null? table) (if (null? table)
(http-error http-reply/not-found #f "node not found")) (http-error http-status/not-found #f "node not found"))
(let* ((entry (car table)) (let* ((entry (car table))
(pos (cdr entry))) (pos (cdr entry)))
(if (and (>= seek-pos pos) (if (and (>= seek-pos pos)
@ -561,7 +561,7 @@
(define (find-node file node find-file) (define (find-node file node find-file)
(if (not file) (if (not file)
(http-error http-reply/not-found #f (http-error http-status/not-found #f
"no file in info node specification")) "no file in info node specification"))
(let* ((fname (find-file file)) (let* ((fname (find-file file))
@ -569,7 +569,7 @@
(let loop ((port port)) (let loop ((port port))
(let ((line (read-line port))) (let ((line (read-line port)))
(if (eof-object? line) (if (eof-object? line)
(http-error http-reply/not-found #f "info node not found")) (http-error http-status/not-found #f "info node not found"))
(if (node-prologue? line) (if (node-prologue? line)
(let ((header (read-line port))) (let ((header (read-line port)))
(if (eof-object? header) (if (eof-object? header)
@ -632,7 +632,7 @@
(let ((alts (info-file-alternative-names file))) (let ((alts (info-file-alternative-names file)))
(let path-loop ((path info-path)) (let path-loop ((path info-path))
(if (null? path) (if (null? path)
(http-error http-reply/not-found #f "info file not found")) (http-error http-status/not-found #f "info file not found"))
(let alt-loop ((alts alts)) (let alt-loop ((alts alts))
(if (null? alts) (if (null? alts)
(path-loop (cdr path)) (path-loop (cdr path))

6
scheme/httpd/logging.scm
View File

@ -7,7 +7,7 @@
;; CLF-logging ;; CLF-logging
;; if enabled, it will look like this: ;; if enabled, it will look like this:
;; (lambda req reply-code) ;; (lambda req status-code)
(define http-log (lambda a #f)) ; makes logging in CLF (define http-log (lambda a #f)) ; makes logging in CLF
;; syslogging ;; syslogging
@ -70,7 +70,7 @@
(define (make-http-log-proc http-log-lock) (define (make-http-log-proc http-log-lock)
; (display "--- MARK (server started) ---\n" http-log-port) ; (display "--- MARK (server started) ---\n" http-log-port)
(lambda (req reply-code) (lambda (req status-code)
(if req (if req
(begin (begin
(obtain-lock http-log-lock) (obtain-lock http-log-lock)
@ -83,7 +83,7 @@
(uri-path-list->path (uri-path-list->path
(http-url:path (request:url req))) ; requested file (http-url:path (request:url req))) ; requested file
(version->string (request:version req)) ; protocol version (version->string (request:version req)) ; protocol version
reply-code status-code
23 ; filesize (unknown) 23 ; filesize (unknown)
(get-header (request:headers req) 'referer) (get-header (request:headers req) 'referer)
(get-header (request:headers req) 'user-agent)) (get-header (request:headers req) 'user-agent))

49
scheme/httpd/reply-codes.scm
View File

@ -1,49 +0,0 @@
;;;; Sending replies
;;;;;;;;;;;;;;;;;;;;
;;; Reply codes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (define http-reply/ok 200), etc.
;;; Also, build an alist HTTP-REPLY-TEXT-TABLE mapping integer reply codes
;;; to their diagnostic text messages.
(define-syntax define-http-reply-codes
(syntax-rules ()
((define-http-reply-codes table set (name val msg) ...)
(begin (define table '((val . msg) ...))
(define-enum-constant set name val)
...))))
(define-http-reply-codes http-reply-text-table http-reply
(ok 200 "OK")
(created 201 "Created")
(accepted 202 "Accepted")
(prov-info 203 "Provisional Information")
(no-content 204 "No Content")
(mult-choice 300 "Multiple Choices")
(moved-perm 301 "Moved Permanently")
(moved-temp 302 "Moved Temporarily")
(method 303 "Method (obsolete)")
(not-mod 304 "Not Modified")
(bad-request 400 "Bad Request")
(unauthorized 401 "Unauthorized")
(payment-req 402 "Payment Required")
(forbidden 403 "Forbidden")
(not-found 404 "Not Found")
(method-not-allowed 405 "Method Not Allowed")
(none-acceptable 406 "None Acceptable")
(proxy-auth-required 407 "Proxy Authentication Required")
(timeout 408 "Request Timeout")
(conflict 409 "Conflict")
(gone 410 "Gone")
(internal-error 500 "Internal Server Error")
(not-implemented 501 "Not Implemented")
(bad-gateway 502 "Bad Gateway")
(service-unavailable 503 "Service Unavailable")
(gateway-timeout 504 "Gateway Timeout"))
(define (reply-code->text code)
(cdr (assv code http-reply-text-table)))

41
scheme/httpd/response.scm
View File

@ -16,3 +16,44 @@
(define (display-http-body body port options) (define (display-http-body body port options)
((writer-body-proc body) port options)) ((writer-body-proc body) port options))
(define-syntax define-http-status-codes
(syntax-rules ()
((define-http-status-codes table set (name val msg) ...)
(begin (define table '((val . msg) ...))
(define-enum-constant set name val)
...))))
(define-http-status-codes http-status-text-table http-status
(ok 200 "OK")
(created 201 "Created")
(accepted 202 "Accepted")
(prov-info 203 "Provisional Information")
(no-content 204 "No Content")
(mult-choice 300 "Multiple Choices")
(moved-perm 301 "Moved Permanently")
(moved-temp 302 "Moved Temporarily")
(method 303 "Method (obsolete)")
(not-mod 304 "Not Modified")
(bad-request 400 "Bad Request")
(unauthorized 401 "Unauthorized")
(payment-req 402 "Payment Required")
(forbidden 403 "Forbidden")
(not-found 404 "Not Found")
(method-not-allowed 405 "Method Not Allowed")
(none-acceptable 406 "None Acceptable")
(proxy-auth-required 407 "Proxy Authentication Required")
(timeout 408 "Request Timeout")
(conflict 409 "Conflict")
(gone 410 "Gone")
(internal-error 500 "Internal Server Error")
(not-implemented 501 "Not Implemented")
(bad-gateway 502 "Bad Gateway")
(service-unavailable 503 "Service Unavailable")
(gateway-timeout 504 "Gateway Timeout"))
(define (status-code->text code)
(cdr (assv code http-status-text-table)))

16
scheme/httpd/rman-gateway.scm
View File

@ -4,11 +4,11 @@
;;; (RosettaMan is based at ;;; (RosettaMan is based at
;;; ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z) ;;; ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
(define rman/rman '(rman -fHTML)) (define rman/rman '("/afs/wsi/rs_aix41/bin/rman" -fHTML))
(define rman/man '(man)) (define rman/man '(man))
(define rman/nroff '(nroff -man)) (define rman/nroff '(nroff -man))
(define rman/gzcat '(zcat)) (define rman/gzcat '("/afs/wsi/rs_aix41/bin/zcat"))
(define rman/zcat '(zcat)) (define rman/zcat '("/afs/wsi/rs_aix41/bin/zcat"))
(define (rman-handler finder referencer address . maybe-man) (define (rman-handler finder referencer address . maybe-man)
(let ((parse-man-url (let ((parse-man-url
@ -47,7 +47,7 @@
(if (not (v0.9-request? req)) (if (not (v0.9-request? req))
(begin (begin
(begin-http-header #t http-reply/ok) (begin-http-header #t http-status/ok)
(write-string "Content-type: text/html\r\n") (write-string "Content-type: text/html\r\n")
(write-string "\r\n"))) (write-string "\r\n")))
@ -56,7 +56,7 @@
(with-tag #t address () (with-tag #t address ()
(display address)))) (display address))))
(else (http-error http-reply/method-not-allowed req))))))) (else (http-error http-status/method-not-allowed req)))))))
(define (cat-man-page key section) (define (cat-man-page key section)
(let ((title (if section (let ((title (if section
@ -85,7 +85,7 @@
stdports))))) stdports)))))
(if (not (zero? status)) (if (not (zero? status))
(http-error http-reply/internal-error #f (http-error http-status/internal-error #f
"internal error emitting man page"))))) "internal error emitting man page")))))
(define parse-man-entry (define parse-man-entry
@ -108,7 +108,7 @@
(with-env (("MANPATH" . ,(string-join man-path ":"))) (with-env (("MANPATH" . ,(string-join man-path ":")))
(run (,@rman/man ,@(if section `(,section) '()) ,key) (run (,@rman/man ,@(if section `(,section) '()) ,key)
stdports)))) stdports))))
(http-error http-reply/not-found #f "man page not found"))))) (http-error http-status/not-found #f "man page not found")))))
(define man-default-sections (define man-default-sections
'("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p")) '("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
@ -167,4 +167,4 @@
(with-cwd (file->man-directory file) (with-cwd (file->man-directory file)
(exec-epf (,@rman/nroff))))) (exec-epf (,@rman/nroff)))))
stdports))) stdports)))
(http-error http-reply/not-found #f "man page not found"))) (http-error http-status/not-found #f "man page not found")))

4
scheme/httpd/scheme-program-server.scm
View File

@ -18,9 +18,9 @@
(if (or (string=? request-method "GET") (if (or (string=? request-method "GET")
(string=? request-method "POST")) ; Could do others also. (string=? request-method "POST")) ; Could do others also.
(wait (fork doit)) (wait (fork doit))
(http-error http-reply/method-not-allowed req)))) (http-error http-status/method-not-allowed req))))
(http-error http-reply/bad-request req "Error ")))) (http-error http-status/bad-request req "Error "))))
(define (runprogram progstring) (define (runprogram progstring)
(let* ( (progsymbol (read (make-string-input-port progstring))) (let* ( (progsymbol (read (make-string-input-port progstring)))

6
scheme/httpd/seval.scm
View File

@ -7,7 +7,7 @@
;;; \r and \n in string for cr and lf. ;;; \r and \n in string for cr and lf.
;;; SWITCH conditional, ? for COND ;;; SWITCH conditional, ? for COND
;;; HTTP request record stucture ;;; HTTP request record stucture
;;; HTTP-ERROR & reply codes ;;; HTTP-ERROR & status codes
;;; Basic path handler support ;;; Basic path handler support
;;; scsh syscalls ;;; scsh syscalls
;;; Pretty-printing P proc. ;;; Pretty-printing P proc.
@ -84,7 +84,7 @@
(with-tag #t PRE () (with-tag #t PRE ()
(for-each p vals))))))) (for-each p vals)))))))
(else (http-error http-reply/method-not-allowed #f req))))) (else (http-error http-status/method-not-allowed #f req)))))
;;; Read an HTTP request entity body from stdin. The Content-length: ;;; Read an HTTP request entity body from stdin. The Content-length:
@ -111,5 +111,5 @@
(http-syslog (syslog-level debug) (http-syslog (syslog-level debug)
"Seval sexp:~%~s~%" s) "Seval sexp:~%~s~%" s)
(read (make-string-input-port s))))) (read (make-string-input-port s)))))
(else (http-error http-reply/bad-request req (else (http-error http-status/bad-request req
"No Content-length: field in POST request.")))) "No Content-length: field in POST request."))))

83
scheme/packages.scm
View File

@ -295,36 +295,6 @@
http-syslog http-syslog
http-log)) http-log))
(define-interface httpd-reply-codes-interface
(export ;; Integer reply codes
reply-code->text
http-reply/ok
http-reply/created
http-reply/accepted
http-reply/prov-info
http-reply/no-content
http-reply/mult-choice
http-reply/moved-perm
http-reply/moved-temp
http-reply/method
http-reply/not-mod
http-reply/bad-request
http-reply/unauthorized
http-reply/payment-req
http-reply/forbidden
http-reply/not-found
http-reply/method-not-allowed
http-reply/none-acceptable
http-reply/proxy-auth-required
http-reply/timeout
http-reply/conflict
http-reply/gone
http-reply/internal-error
http-reply/not-implemented
http-reply/bad-gateway
http-reply/service-unavailable
http-reply/gateway-timeout))
(define-interface httpd-request-interface (define-interface httpd-request-interface
(export make-request ; HTTP request (export make-request ; HTTP request
request? ; record type. request? ; record type.
@ -363,7 +333,36 @@
response-body response-body
make-writer-body writer-body? make-writer-body writer-body?
display-http-body)) display-http-body
;; Integer reply codes
status-code->text
http-status/ok
http-status/created
http-status/accepted
http-status/prov-info
http-status/no-content
http-status/mult-choice
http-status/moved-perm
http-status/moved-temp
http-status/method
http-status/not-mod
http-status/bad-request
http-status/unauthorized
http-status/payment-req
http-status/forbidden
http-status/not-found
http-status/method-not-allowed
http-status/none-acceptable
http-status/proxy-auth-required
http-status/timeout
http-status/conflict
http-status/gone
http-status/internal-error
http-status/not-implemented
http-status/bad-gateway
http-status/service-unavailable
http-status/gateway-timeout))
(define-interface httpd-basic-handlers-interface (define-interface httpd-basic-handlers-interface
(export make-request-handler (export make-request-handler
@ -664,7 +663,6 @@
httpd-error httpd-error
httpd-logging httpd-logging
httpd-request httpd-request
httpd-reply-codes
httpd-constants httpd-constants
httpd-responses httpd-responses
httpd-text-generation httpd-text-generation
@ -679,7 +677,7 @@
(define-structure httpd-access-control httpd-access-control-interface (define-structure httpd-access-control httpd-access-control-interface
(open big-scheme (open big-scheme
httpd-reply-codes httpd-responses
httpd-request httpd-request
httpd-error httpd-error
string-lib ; STRING-MAP string-lib ; STRING-MAP
@ -710,11 +708,6 @@
scheme) scheme)
(files (httpd logging))) (files (httpd logging)))
(define-structure httpd-reply-codes httpd-reply-codes-interface
(open defenum-package
scheme)
(files (httpd reply-codes)))
(define-structure httpd-request httpd-request-interface (define-structure httpd-request httpd-request-interface
(open define-record-types ;; define-record-discloser (open define-record-types ;; define-record-discloser
defrec-package ;; define-record defrec-package ;; define-record
@ -727,7 +720,7 @@
(define-structure httpd-text-generation httpd-text-generation-interface (define-structure httpd-text-generation httpd-text-generation-interface
(open formats (open formats
httpd-reply-codes ; reply-code->text httpd-responses ; status-code->text
crlf-io crlf-io
httpd-constants httpd-constants
scheme scheme
@ -736,7 +729,8 @@
(define-structure httpd-responses httpd-responses-interface (define-structure httpd-responses httpd-responses-interface
(open scheme (open scheme
srfi-9) srfi-9
defenum-package)
(files (httpd response))) (files (httpd response)))
(define-structure httpd-basic-handlers httpd-basic-handlers-interface (define-structure httpd-basic-handlers httpd-basic-handlers-interface
@ -751,7 +745,6 @@
(open scheme scsh (open scheme scsh
httpd-core httpd-core
httpd-request httpd-request
httpd-reply-codes
httpd-responses httpd-responses
httpd-text-generation httpd-text-generation
httpd-error httpd-error
@ -769,8 +762,8 @@
(open scsh ; syscalls & INDEX (open scsh ; syscalls & INDEX
httpd-error httpd-error
httpd-request ; v0.9-request httpd-request ; v0.9-request
httpd-reply-codes
httpd-text-generation ; begin-http-header httpd-text-generation ; begin-http-header
httpd-responses
httpd-logging ; http-log httpd-logging ; http-log
uri ; UNESCAPE-URI uri ; UNESCAPE-URI
htmlout ; Formatted HTML output htmlout ; Formatted HTML output
@ -792,7 +785,7 @@
htmlout htmlout
httpd-request httpd-request
httpd-text-generation httpd-text-generation
httpd-reply-codes httpd-responses
httpd-error httpd-error
url url
uri uri
@ -802,7 +795,7 @@
(files (httpd info-gateway))) (files (httpd info-gateway)))
(define-structure rman-gateway rman-gateway-interface (define-structure rman-gateway rman-gateway-interface
(open httpd-reply-codes (open httpd-responses
httpd-request httpd-request
httpd-text-generation httpd-text-generation
httpd-error httpd-error
@ -827,7 +820,7 @@
httpd-constants httpd-constants
httpd-logging httpd-logging
httpd-request httpd-request
httpd-reply-codes httpd-responses
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
httpd-error ; HTTP-ERROR httpd-error ; HTTP-ERROR
scsh-utilities ; INDEX scsh-utilities ; INDEX