Adopt proper RFC terminology:
"reply" -> "response" "reply code" -> "status code"
This commit is contained in:
sperber
parent
d1438eb4a8
commit
6f7cd467f1
|
|
@ -32,7 +32,7 @@
|
|||
(if (eq?
|
||||
(control (host-info (socket-remote-address (request:socket req))))
|
||||
'deny)
|
||||
(http-error http-reply/forbidden req)
|
||||
(http-error http-status/forbidden req)
|
||||
(ph path req))))
|
||||
|
||||
(define (address->list address)
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
;;; SWITCH conditional
|
||||
;;; RFC822 header parsing
|
||||
;;; HTTP request record structure
|
||||
;;; HTTP-ERROR & reply codes
|
||||
;;; HTTP-ERROR & status codes
|
||||
;;; Basic path handler support (for ncsa-handler)
|
||||
|
||||
;;; PROBLEMS:
|
||||
|
|
@ -68,15 +68,15 @@
|
|||
;;; - 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.
|
||||
;;; - 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
|
||||
;;; 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).
|
||||
;;;
|
||||
;;; 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 POST and GET ops; any other op generates a "405 Method not allowed"
|
||||
;;; reply.
|
||||
;;; response.
|
||||
|
||||
;;; Parameters
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
(let* ((prog (car path))
|
||||
|
||||
(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."))))
|
||||
|
||||
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
|
||||
|
|
@ -129,15 +129,15 @@
|
|||
(if nph?
|
||||
(let ((stat (wait (fork doit))))
|
||||
(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."
|
||||
filename))
|
||||
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)
|
||||
|
|
@ -219,7 +219,7 @@
|
|||
(cl-len (string-length cl)))
|
||||
(if first-digit
|
||||
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
|
||||
(http-error http-reply/bad-request
|
||||
(http-error http-status/bad-request
|
||||
req
|
||||
"Illegal Content-length: header.")))))
|
||||
|
||||
|
|
@ -238,10 +238,10 @@
|
|||
|
||||
|
||||
;;; 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
|
||||
;;; it into a real HTTP reply, which we then send back to the HTTP client.
|
||||
;;; The script isn't an "nph-" script, so we read the response, and mutate
|
||||
;;; 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))
|
||||
(ctype (get-header headers 'content-type)) ; The script headers
|
||||
(loc (get-header headers 'location))
|
||||
|
|
@ -252,13 +252,13 @@
|
|||
((null? (cdr stat-lines)) ; One line status header.
|
||||
(car stat-lines))
|
||||
(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")))))
|
||||
(out (current-output-port)))
|
||||
|
||||
(http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers)
|
||||
;; Send the reply header back to the client
|
||||
;; (unless it's a headerless HTTP 0.9 reply).
|
||||
;; Send the response header back to the client
|
||||
;; (unless it's a headerless HTTP 0.9 response).
|
||||
(if (not (v0.9-request? req))
|
||||
(begin
|
||||
(format out "HTTP/1.0 ~a\r~%" stat)
|
||||
|
|
@ -267,7 +267,7 @@
|
|||
(write-crlf out)))
|
||||
|
||||
(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).
|
||||
(if (not (string=? (request:method req) "HEAD"))
|
||||
(begin
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@
|
|||
;;; 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
|
||||
;;; 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
|
||||
;;; handle the various errors, which introduces a major point of R4RS
|
||||
;;; incompatibiliy -- R4RS has no exception system. So if you were to port
|
||||
|
|
@ -111,7 +111,7 @@
|
|||
|
||||
(define (process-toplevel-request sock host-address options)
|
||||
;; 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
|
||||
;; PROCESS-TOPLEVEL-REQUEST.
|
||||
;;
|
||||
|
|
@ -145,15 +145,15 @@
|
|||
c)
|
||||
(cond
|
||||
((http-error? c)
|
||||
(apply (lambda (reply-code req . args)
|
||||
(apply (lambda (status-code req . args)
|
||||
(values req
|
||||
(apply make-http-error-response
|
||||
reply-code req
|
||||
status-code req
|
||||
args)))
|
||||
(condition-stuff c)))
|
||||
((fatal-syntax-error? c)
|
||||
(values #f
|
||||
(apply make-http-error-response http-reply/bad-request
|
||||
(apply make-http-error-response http-status/bad-request
|
||||
#f ; No request yet.
|
||||
"Request parsing error -- report to client maintainer."
|
||||
(condition-stuff c))))
|
||||
|
|
@ -167,7 +167,7 @@
|
|||
(values req response)))))
|
||||
(lambda (req response)
|
||||
(send-http-response response (socket:outport sock) options)
|
||||
(http-log req http-reply/ok))))))
|
||||
(http-log req http-status/ok))))))
|
||||
|
||||
;;;; HTTP request parsing
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -302,9 +302,9 @@
|
|||
(write-crlf port))
|
||||
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
|
||||
;;; 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
|
||||
;;; 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
|
||||
(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)
|
||||
(http-log req reply-code)
|
||||
(define (really-make-http-error-response status-code req . args)
|
||||
(http-log req status-code)
|
||||
|
||||
(let* ((message (and (pair? args) (car args)))
|
||||
(extras (if (pair? args) (cdr args) '()))
|
||||
|
||||
(generic-title (lambda (port)
|
||||
(title-html port
|
||||
(reply-code->text reply-code))))
|
||||
(status-code->text status-code))))
|
||||
(close-html (lambda (port)
|
||||
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
|
||||
(write-string "</BODY>\n" port)))
|
||||
|
||||
(create-response
|
||||
(lambda (headers writer-proc)
|
||||
(make-response reply-code
|
||||
(reply-code->text reply-code)
|
||||
(make-response status-code
|
||||
(status-code->text status-code)
|
||||
(time)
|
||||
"text/html"
|
||||
headers
|
||||
(make-writer-body writer-proc)))))
|
||||
|
||||
(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.
|
||||
((or (= reply-code http-reply/moved-temp)
|
||||
(= reply-code http-reply/moved-perm))
|
||||
((or (= status-code http-status/moved-temp)
|
||||
(= status-code http-status/moved-perm))
|
||||
(create-response
|
||||
(list (cons 'uri message)
|
||||
(cons 'location (car extras)))
|
||||
|
|
@ -355,11 +355,11 @@
|
|||
(title-html port "Document moved")
|
||||
(format port
|
||||
"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)
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/bad-request)
|
||||
((= status-code http-status/bad-request)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
|
|
@ -369,7 +369,7 @@
|
|||
(if message (format port "<BR>~%Reason: ~A~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/unauthorized)
|
||||
((= status-code http-status/unauthorized)
|
||||
(create-response
|
||||
(list (cons 'WWW-Authenticate message)) ; Vas is das?
|
||||
(lambda (port options)
|
||||
|
|
@ -379,7 +379,7 @@
|
|||
(if message (format port "~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/forbidden)
|
||||
((= status-code http-status/forbidden)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
|
|
@ -391,7 +391,7 @@
|
|||
(if message (format port "<P>~%~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/not-found)
|
||||
((= status-code http-status/not-found)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
|
|
@ -402,7 +402,7 @@
|
|||
(if message (format port "<P>~%~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/internal-error)
|
||||
((= status-code http-status/internal-error)
|
||||
(http-syslog (syslog-level error) "internal-error: ~A" message)
|
||||
(create-response
|
||||
'()
|
||||
|
|
@ -417,7 +417,7 @@ the error, and time it occured.~%"
|
|||
(if message (format port "<P>~%~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/not-implemented)
|
||||
((= status-code http-status/not-implemented)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
|
|
@ -429,7 +429,7 @@ the requested method (~A).~%"
|
|||
(close-html port))))
|
||||
|
||||
(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
|
||||
'()
|
||||
(lambda (port options)
|
||||
|
|
|
|||
|
|
@ -11,16 +11,16 @@
|
|||
;;; 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
|
||||
;;; 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 http-error? (condition-predicate 'http-error))
|
||||
|
||||
(define (http-error error-code req . args)
|
||||
(apply signal 'http-error error-code req args))
|
||||
(define (http-error status-code req . args)
|
||||
(apply signal 'http-error status-code req args))
|
||||
|
||||
;;; Syntax error condition
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
(cdr path)
|
||||
file-serve-response
|
||||
req)
|
||||
(make-http-error-response http-reply/bad-request
|
||||
(make-http-error-response http-status/bad-request
|
||||
req
|
||||
"Path contains no home directory."))))
|
||||
|
||||
|
|
@ -69,11 +69,11 @@
|
|||
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.
|
||||
|
||||
(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
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -109,13 +109,13 @@
|
|||
|
||||
(define (make-rooted-file-path-response root file-path file-serve-response 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.")
|
||||
(cond ((dotdot-check root file-path) =>
|
||||
(lambda (fname)
|
||||
(file-serve-response fname file-path req)))
|
||||
(else
|
||||
(make-http-error-response http-reply/bad-request req
|
||||
(make-http-error-response http-status/bad-request req
|
||||
"URL contains unresolvable ..'s.")))))
|
||||
|
||||
|
||||
|
|
@ -125,9 +125,9 @@
|
|||
(with-errno-handler
|
||||
((errno packet)
|
||||
((errno/noent)
|
||||
(http-error http-reply/not-found req))
|
||||
(http-error http-status/not-found req))
|
||||
((errno/acces)
|
||||
(http-error http-reply/forbidden req)))
|
||||
(http-error http-status/forbidden req)))
|
||||
(file-info fname #t)))
|
||||
|
||||
;;; A basic file request handler -- ship the dude the file. No fancy path
|
||||
|
|
@ -150,14 +150,14 @@
|
|||
|
||||
((directory) ; Send back a redirection "foo" -> "foo/"
|
||||
(make-http-error-response
|
||||
http-reply/moved-perm req
|
||||
http-status/moved-perm req
|
||||
(string-append (request:uri 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)
|
||||
(file-serve-response (string-append fname "index.html") file-path req))
|
||||
|
|
@ -347,10 +347,10 @@
|
|||
|
||||
(if (not (eq? 'directory
|
||||
(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
|
||||
http-reply/ok
|
||||
(reply-code->text http-reply/ok)
|
||||
http-status/ok
|
||||
(status-code->text http-status/ok)
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
|
|
@ -392,7 +392,7 @@
|
|||
(emit-tag port 'hr)
|
||||
(format port "~d files" n-files))))))))))))
|
||||
(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)
|
||||
(let ((index-fname (string-append fname "index.html")))
|
||||
|
|
@ -404,11 +404,11 @@
|
|||
(file-serve-or-dir-response fname file-path req
|
||||
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)
|
||||
(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."
|
||||
(condition-stuff c)))
|
||||
|
||||
|
|
@ -417,11 +417,11 @@
|
|||
|
||||
(define (send-file-response filename info req)
|
||||
(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)
|
||||
(file-extension->content-encoding filename)
|
||||
(make-response http-reply/ok
|
||||
(reply-code->text http-reply/ok)
|
||||
(make-response http-status/ok
|
||||
(status-code->text http-status/ok)
|
||||
(time)
|
||||
(file-extension->content-type stripped-filename)
|
||||
(append (if content-encoding
|
||||
|
|
|
|||
|
|
@ -136,7 +136,7 @@
|
|||
(lambda (c decline)
|
||||
(cond
|
||||
((info-gateway-error? c)
|
||||
(apply http-error http-reply/internal-error req
|
||||
(apply http-error http-status/internal-error req
|
||||
(condition-stuff c)))
|
||||
((http-error? c)
|
||||
(apply http-error (car (condition-stuff c)) req
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
|
||||
(if (not (v0.9-request? req))
|
||||
(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 "\r\n")))
|
||||
|
||||
|
|
@ -158,7 +158,7 @@
|
|||
|
||||
(with-tag #t 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
|
||||
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))
|
||||
|
|
@ -508,7 +508,7 @@
|
|||
(if (eof-object? line)
|
||||
(info-gateway-error "invalid info file"))
|
||||
(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)
|
||||
(if (string=? node entry-node)
|
||||
(cons file seek)
|
||||
|
|
@ -517,7 +517,7 @@
|
|||
(define (find-indirection-entry seek-pos indirection-table)
|
||||
(let loop ((table indirection-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))
|
||||
(pos (cdr entry)))
|
||||
(if (and (>= seek-pos pos)
|
||||
|
|
@ -561,7 +561,7 @@
|
|||
|
||||
(define (find-node file node find-file)
|
||||
(if (not file)
|
||||
(http-error http-reply/not-found #f
|
||||
(http-error http-status/not-found #f
|
||||
"no file in info node specification"))
|
||||
|
||||
(let* ((fname (find-file file))
|
||||
|
|
@ -569,7 +569,7 @@
|
|||
(let loop ((port port))
|
||||
(let ((line (read-line port)))
|
||||
(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)
|
||||
(let ((header (read-line port)))
|
||||
(if (eof-object? header)
|
||||
|
|
@ -632,7 +632,7 @@
|
|||
(let ((alts (info-file-alternative-names file)))
|
||||
(let path-loop ((path info-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))
|
||||
(if (null? alts)
|
||||
(path-loop (cdr path))
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
;; CLF-logging
|
||||
;; 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
|
||||
|
||||
;; syslogging
|
||||
|
|
@ -70,7 +70,7 @@
|
|||
|
||||
(define (make-http-log-proc http-log-lock)
|
||||
; (display "--- MARK (server started) ---\n" http-log-port)
|
||||
(lambda (req reply-code)
|
||||
(lambda (req status-code)
|
||||
(if req
|
||||
(begin
|
||||
(obtain-lock http-log-lock)
|
||||
|
|
@ -83,7 +83,7 @@
|
|||
(uri-path-list->path
|
||||
(http-url:path (request:url req))) ; requested file
|
||||
(version->string (request:version req)) ; protocol version
|
||||
reply-code
|
||||
status-code
|
||||
23 ; filesize (unknown)
|
||||
(get-header (request:headers req) 'referer)
|
||||
(get-header (request:headers req) 'user-agent))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -16,3 +16,44 @@
|
|||
(define (display-http-body 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)))
|
||||
|
|
@ -4,11 +4,11 @@
|
|||
;;; (RosettaMan is based at
|
||||
;;; 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/nroff '(nroff -man))
|
||||
(define rman/gzcat '(zcat))
|
||||
(define rman/zcat '(zcat))
|
||||
(define rman/gzcat '("/afs/wsi/rs_aix41/bin/zcat"))
|
||||
(define rman/zcat '("/afs/wsi/rs_aix41/bin/zcat"))
|
||||
|
||||
(define (rman-handler finder referencer address . maybe-man)
|
||||
(let ((parse-man-url
|
||||
|
|
@ -47,7 +47,7 @@
|
|||
|
||||
(if (not (v0.9-request? req))
|
||||
(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 "\r\n")))
|
||||
|
||||
|
|
@ -56,7 +56,7 @@
|
|||
|
||||
(with-tag #t 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)
|
||||
(let ((title (if section
|
||||
|
|
@ -85,7 +85,7 @@
|
|||
stdports)))))
|
||||
|
||||
(if (not (zero? status))
|
||||
(http-error http-reply/internal-error #f
|
||||
(http-error http-status/internal-error #f
|
||||
"internal error emitting man page")))))
|
||||
|
||||
(define parse-man-entry
|
||||
|
|
@ -108,7 +108,7 @@
|
|||
(with-env (("MANPATH" . ,(string-join man-path ":")))
|
||||
(run (,@rman/man ,@(if section `(,section) '()) ,key)
|
||||
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
|
||||
'("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
|
||||
|
|
@ -167,4 +167,4 @@
|
|||
(with-cwd (file->man-directory file)
|
||||
(exec-epf (,@rman/nroff)))))
|
||||
stdports)))
|
||||
(http-error http-reply/not-found #f "man page not found")))
|
||||
(http-error http-status/not-found #f "man page not found")))
|
||||
|
|
|
|||
|
|
@ -18,9 +18,9 @@
|
|||
(if (or (string=? request-method "GET")
|
||||
(string=? request-method "POST")) ; Could do others also.
|
||||
(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)
|
||||
(let* ( (progsymbol (read (make-string-input-port progstring)))
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
;;; \r and \n in string for cr and lf.
|
||||
;;; SWITCH conditional, ? for COND
|
||||
;;; HTTP request record stucture
|
||||
;;; HTTP-ERROR & reply codes
|
||||
;;; HTTP-ERROR & status codes
|
||||
;;; Basic path handler support
|
||||
;;; scsh syscalls
|
||||
;;; Pretty-printing P proc.
|
||||
|
|
@ -84,7 +84,7 @@
|
|||
(with-tag #t PRE ()
|
||||
(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:
|
||||
|
|
@ -111,5 +111,5 @@
|
|||
(http-syslog (syslog-level debug)
|
||||
"Seval sexp:~%~s~%" 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."))))
|
||||
|
|
|
|||
|
|
@ -295,36 +295,6 @@
|
|||
http-syslog
|
||||
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
|
||||
(export make-request ; HTTP request
|
||||
request? ; record type.
|
||||
|
|
@ -363,7 +333,36 @@
|
|||
response-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
|
||||
(export make-request-handler
|
||||
|
|
@ -664,7 +663,6 @@
|
|||
httpd-error
|
||||
httpd-logging
|
||||
httpd-request
|
||||
httpd-reply-codes
|
||||
httpd-constants
|
||||
httpd-responses
|
||||
httpd-text-generation
|
||||
|
|
@ -679,7 +677,7 @@
|
|||
|
||||
(define-structure httpd-access-control httpd-access-control-interface
|
||||
(open big-scheme
|
||||
httpd-reply-codes
|
||||
httpd-responses
|
||||
httpd-request
|
||||
httpd-error
|
||||
string-lib ; STRING-MAP
|
||||
|
|
@ -710,11 +708,6 @@
|
|||
scheme)
|
||||
(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
|
||||
(open define-record-types ;; define-record-discloser
|
||||
defrec-package ;; define-record
|
||||
|
|
@ -727,7 +720,7 @@
|
|||
|
||||
(define-structure httpd-text-generation httpd-text-generation-interface
|
||||
(open formats
|
||||
httpd-reply-codes ; reply-code->text
|
||||
httpd-responses ; status-code->text
|
||||
crlf-io
|
||||
httpd-constants
|
||||
scheme
|
||||
|
|
@ -736,7 +729,8 @@
|
|||
|
||||
(define-structure httpd-responses httpd-responses-interface
|
||||
(open scheme
|
||||
srfi-9)
|
||||
srfi-9
|
||||
defenum-package)
|
||||
(files (httpd response)))
|
||||
|
||||
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
||||
|
|
@ -751,7 +745,6 @@
|
|||
(open scheme scsh
|
||||
httpd-core
|
||||
httpd-request
|
||||
httpd-reply-codes
|
||||
httpd-responses
|
||||
httpd-text-generation
|
||||
httpd-error
|
||||
|
|
@ -769,8 +762,8 @@
|
|||
(open scsh ; syscalls & INDEX
|
||||
httpd-error
|
||||
httpd-request ; v0.9-request
|
||||
httpd-reply-codes
|
||||
httpd-text-generation ; begin-http-header
|
||||
httpd-responses
|
||||
httpd-logging ; http-log
|
||||
uri ; UNESCAPE-URI
|
||||
htmlout ; Formatted HTML output
|
||||
|
|
@ -792,7 +785,7 @@
|
|||
htmlout
|
||||
httpd-request
|
||||
httpd-text-generation
|
||||
httpd-reply-codes
|
||||
httpd-responses
|
||||
httpd-error
|
||||
url
|
||||
uri
|
||||
|
|
@ -802,7 +795,7 @@
|
|||
(files (httpd info-gateway)))
|
||||
|
||||
(define-structure rman-gateway rman-gateway-interface
|
||||
(open httpd-reply-codes
|
||||
(open httpd-responses
|
||||
httpd-request
|
||||
httpd-text-generation
|
||||
httpd-error
|
||||
|
|
@ -827,7 +820,7 @@
|
|||
httpd-constants
|
||||
httpd-logging
|
||||
httpd-request
|
||||
httpd-reply-codes
|
||||
httpd-responses
|
||||
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
||||
httpd-error ; HTTP-ERROR
|
||||
scsh-utilities ; INDEX
|
||||
|
|
|
|||
Loading…
Reference in New Issue