From 0754b749630bd50b8add5b32c89e3591389c6a7c Mon Sep 17 00:00:00 2001 From: sperber Date: Thu, 9 Jan 2003 15:05:30 +0000 Subject: [PATCH] Replace integer HTTP status codes by finite record type instances. --- scheme/httpd/access-control.scm | 2 +- scheme/httpd/cgi-server.scm | 22 ++-- scheme/httpd/core.scm | 14 +- scheme/httpd/file-dir-handler.scm | 32 ++--- scheme/httpd/handlers.scm | 2 +- scheme/httpd/info-gateway.scm | 18 +-- scheme/httpd/logging.scm | 2 +- scheme/httpd/response.scm | 121 ++++++++---------- scheme/httpd/rman-gateway.scm | 10 +- scheme/httpd/seval.scm | 6 +- scheme/httpd/surflets/surflet-handler.scm | 14 +- scheme/httpd/surflets/surflets.scm | 6 +- .../web-server/root/surflets/add-html.scm | 2 +- .../web-server/root/surflets/add-raw.scm | 10 +- .../root/surflets/admin-handler.scm | 2 +- .../root/surflets/admin-profiling.scm | 2 +- .../root/surflets/admin-servlets-cb.scm | 2 +- .../root/surflets/admin-servlets.scm | 2 +- scheme/packages.scm | 37 +----- 19 files changed, 135 insertions(+), 171 deletions(-) diff --git a/scheme/httpd/access-control.scm b/scheme/httpd/access-control.scm index 014d80b..9e83fa5 100644 --- a/scheme/httpd/access-control.scm +++ b/scheme/httpd/access-control.scm @@ -36,7 +36,7 @@ (if (eq? (control (host-info (socket-remote-address (request-socket req)))) 'deny) - (http-error http-status/forbidden req) + (http-error (status-code forbidden) req) (ph path req)))) (define (address->list address) diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index e1188f1..d3678e2 100644 --- a/scheme/httpd/cgi-server.scm +++ b/scheme/httpd/cgi-server.scm @@ -91,13 +91,13 @@ (lambda (path req) (if (pair? path) ; Got to have at least one elt. (compute-cgi path req bin-dir request-invariant-cgi-env) - (make-http-error-response http-status/bad-request req "Empty CGI script")))))) + (make-http-error-response (status-code bad-request) req "Empty CGI script")))))) (define (compute-cgi path req bin-dir request-invariant-cgi-env) (let* ((prog (car path)) (filename (or (dotdot-check bin-dir (list prog)) - (http-error http-status/bad-request req + (http-error (status-code bad-request) req "CGI scripts may not contain \"..\" elements."))) (nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ? @@ -125,22 +125,22 @@ (let ((stat (wait (fork doit)))) (if (not (zero? stat)) (make-http-error-response - http-status/bad-request req + (status-code bad-request) req (format #f "Could not execute CGI script ~a." filename)) stat)) ;; FIXME! must return http-response object! (case (file-not-executable? filename) ((search-denied permission) - (make-http-error-response http-status/forbidden req + (make-http-error-response (status-code forbidden) req "Permission denied.")) ((no-directory nonexistent) - (make-http-error-response http-status/not-found req + (make-http-error-response (status-code not-found) req "File or directory doesn't exist.")) (else (cgi-make-response (run/port* doit) path req))))) (else - (make-http-error-response http-status/method-not-allowed req request-method)))))) + (make-http-error-response (status-code method-not-allowed) req request-method)))))) (define (split-and-decode-search-spec s) @@ -222,7 +222,7 @@ (cl-len (string-length cl))) (if first-digit `(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len))) - (http-error http-status/bad-request req + (http-error (status-code bad-request) req "Illegal `Content-length:' header."))))) (else '())) @@ -260,7 +260,7 @@ (if loc (if (uri-has-protocol? (string-trim loc)) - (make-http-error-response http-status/moved-perm req + (make-http-error-response (status-code moved-perm) req loc loc) (make-redirect-response (string-trim loc))) ;; Send the response header back to the client @@ -284,11 +284,11 @@ (define (extract-status-code-and-text stat-lines req) (cond ((not (pair? stat-lines)) ; No status header. - (cons http-status/ok "The idiot CGI script left out the status line.")) + (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 http-status/bad-gateway req + (http-error (status-code bad-gateway) req "CGI script generated an invalid status header." (car stat-lines) c)) (lambda () @@ -296,5 +296,5 @@ (cons (string->number (substring status 0 3)) ; number (substring/shared status 4)))))) ; text (else ; Vas ist das? - (http-error http-status/bad-gateway req + (http-error (status-code bad-gateway) req "CGI script generated multi-line status header.")))) \ No newline at end of file diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 8e33ad9..646dbd5 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -148,7 +148,7 @@ (condition-stuff c))) ((fatal-syntax-error? c) (values #f - (apply make-http-error-response http-status/bad-request + (apply make-http-error-response (status-code bad-request) #f ; No request yet. "Request parsing error -- report to client maintainer." (condition-stuff c)))) @@ -158,7 +158,7 @@ ;; try to send bug report to client (values #f - (apply make-http-error-response http-status/internal-error + (apply make-http-error-response (status-code internal-error) #f ; don't know "Internal error occured while processing request" c))) @@ -171,7 +171,7 @@ (http-url-path (request-url req)) req))) (if (eq? (response-code response) - http-status/redirect) + (status-code redirect)) (redirect-loop (redirect-request req response sock options)) (values req response)))))))) (lambda (req response) @@ -187,7 +187,7 @@ (url (with-fatal-error-handler* (lambda (c decline) (if (fatal-syntax-error? c) - (http-error http-status/internal-error req + (http-error (status-code internal-error) req (format #f "Bad redirection out from CGI program: ~%~a" (cdr c))) (decline c))) @@ -315,9 +315,11 @@ (define (send-http-headers response port) (display server/protocol port) (write-char #\space port) - (display (response-code response) port) + (display (status-code-number (response-code response)) port) (write-char #\space port) - (display (response-message response) port) + (display (or (response-message response) + (status-code-message (response-code response))) + port) (write-crlf port) (send-http-header-fields diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm index 0f81dc7..64ff9bd 100644 --- a/scheme/httpd/file-dir-handler.scm +++ b/scheme/httpd/file-dir-handler.scm @@ -25,7 +25,7 @@ (define (home-dir-handler user-public-dir) (lambda (path req) (if (null? path) - (make-http-error-response http-status/bad-request + (make-http-error-response (status-code bad-request) req "Path contains no home directory.") (make-rooted-file-path-response (string-append (http-homedir (car path) req) @@ -113,13 +113,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-status/bad-request req + (make-http-error-response (status-code 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-status/bad-request req + (make-http-error-response (status-code bad-request) req "URL contains unresolvable ..'s."))))) @@ -129,9 +129,9 @@ (with-errno-handler ((errno packet) ((errno/noent) - (http-error http-status/not-found req)) + (http-error (status-code not-found) req)) ((errno/acces) - (http-error http-status/forbidden req))) + (http-error (status-code forbidden) req))) (file-info fname #t))) ;;; A basic file request handler -- ship the dude the file. No fancy path @@ -154,15 +154,15 @@ ((directory) ; Send back a redirection "foo" -> "foo/" (make-http-error-response - http-status/moved-perm req + (status-code moved-perm) req (string-append (request-uri req) "/") (string-append (http-url->string (request-url req)) "/"))) - (else (make-http-error-response http-status/forbidden req))))) + (else (make-http-error-response (status-code forbidden) req))))) (else - (make-http-error-response http-status/method-not-allowed req + (make-http-error-response (status-code method-not-allowed) req request-method)))))) (define (directory-index-serve-response fname file-path req) @@ -360,10 +360,10 @@ (if (not (eq? 'directory (file-info:type (file-info fname #t)))) - (make-http-error-response http-status/forbidden req) + (make-http-error-response (status-code forbidden) req) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() @@ -405,7 +405,7 @@ (emit-tag port 'hr) (format port "~d files" n-files)))))))))))) (else - (make-http-error-response http-status/method-not-allowed req + (make-http-error-response (status-code method-not-allowed) req request-method))))) (define (index-or-directory-serve-response fname file-path req) @@ -422,7 +422,7 @@ (define (http-homedir username req) (with-fatal-error-handler (lambda (c decline) - (apply http-error http-status/bad-request req + (apply http-error (status-code bad-request) req "Couldn't find user's home directory." (condition-stuff c))) @@ -431,11 +431,11 @@ (define (send-file-response filename info req) (if (file-not-readable? filename) ; #### double stats are no good - (make-http-error-response http-status/not-found req) + (make-http-error-response (status-code not-found) req) (receive (stripped-filename content-encoding) (file-extension->content-encoding filename) - (make-response http-status/ok - (status-code->text http-status/ok) + (make-response (status-code ok) + #f (time) (file-extension->content-type stripped-filename) (append (if content-encoding diff --git a/scheme/httpd/handlers.scm b/scheme/httpd/handlers.scm index c646431..0b66ebd 100644 --- a/scheme/httpd/handlers.scm +++ b/scheme/httpd/handlers.scm @@ -85,4 +85,4 @@ ;;; Can be useful as the default in table-driven request handlers. (define (null-request-handler path req) - (make-http-error-response http-status/not-found req)) + (make-http-error-response (status-code not-found) req)) diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm index ccf2785..6ac8bd4 100644 --- a/scheme/httpd/info-gateway.scm +++ b/scheme/httpd/info-gateway.scm @@ -141,7 +141,7 @@ (lambda (c decline) (cond ((info-gateway-error? c) - (apply http-error http-status/bad-gateway req + (apply http-error (status-code bad-gateway) req (condition-stuff c))) ((http-error? c) (apply http-error (car (condition-stuff c)) req @@ -150,8 +150,8 @@ (decline)))) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() @@ -168,7 +168,7 @@ (write-string address out))))))) (else - (make-http-error-response http-status/method-not-allowed req + (make-http-error-response (status-code method-not-allowed) req request-method))))))) (define split-header-line @@ -520,7 +520,7 @@ (if (eof-object? line) (info-gateway-error "invalid info file")) (if (regexp-exec node-epilogue-regexp line) - (http-error http-status/not-found #f "node not found")) + (http-error (status-code not-found) #f "node not found")) (receive (entry-node file seek) (parse-tag line) (if (string=? node entry-node) (cons file seek) @@ -529,7 +529,7 @@ (define (find-indirection-entry seek-pos indirection-table) (let loop ((table indirection-table)) (if (null? table) - (http-error http-status/not-found #f "node not found")) + (http-error (status-code not-found) #f "node not found")) (let* ((entry (car table)) (pos (cdr entry))) (if (and (>= seek-pos pos) @@ -573,7 +573,7 @@ (define (find-node file node find-file) (if (not file) - (http-error http-status/not-found #f + (http-error (status-code not-found) #f "no file in info node specification")) (let* ((fname (find-file file)) @@ -581,7 +581,7 @@ (let loop ((port port)) (let ((line (read-line port))) (if (eof-object? line) - (http-error http-status/not-found #f "info node not found")) + (http-error (status-code not-found) #f "info node not found")) (if (node-prologue? line) (let ((header (read-line port))) (if (eof-object? header) @@ -644,7 +644,7 @@ (let ((alts (info-file-alternative-names file))) (let path-loop ((path info-path)) (if (null? path) - (http-error http-status/not-found #f "info file not found")) + (http-error (status-code not-found) #f "info file not found")) (let alt-loop ((alts alts)) (if (null? alts) (path-loop (cdr path)) diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm index 62421f1..7da9474 100644 --- a/scheme/httpd/logging.scm +++ b/scheme/httpd/logging.scm @@ -126,7 +126,7 @@ (uri-path-list->path (http-url-path (request-url req))) ; requested file (version->string (request-version req)) ; protocol version - status-code + (status-code-number status-code) 23 ; filesize (unknown) (get-header (request-headers req) 'referer) (get-header (request-headers req) 'user-agent)) diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index 7ad6c1f..e719411 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -37,50 +37,47 @@ ((reader-writer-body? body) ((reader-writer-body-proc body) iport oport options)))) +(define-finite-type status-code :http-status-code + (number message) + status-code? + status-codes + status-code-name + status-code-index + (number status-code-number) + (message status-code-message) + ( + (ok 200 "OK") + (created 201 "Created") + (accepted 202 "Accepted") + (prov-info 203 "Provisional Information") + (no-content 204 "No Content") -(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) - ...)))) + (mult-choice 300 "Multiple Choices") + (moved-perm 301 "Moved Permanently") + (moved-temp 302 "Moved Temporarily") + (method 303 "Method (obsolete)") + (not-mod 304 "Not Modified") -(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") + (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") - (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") + (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") - (redirect -301 "Internal redirect")) + (redirect -301 "Internal redirect"))) -(define (status-code->text code) - (cdr (assv code http-status-text-table))) - ;;; (make-http-error-response status-code req [message . extras]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Take an http-error condition, and format it into a response to the client. @@ -89,15 +86,13 @@ ;;; even had a chance to parse and construct the request. This is only used ;;; for 400 BAD-REQUEST error report. -(define (make-http-error-response status-code req . args) - (http-log req status-code) - +(define (make-http-error-response code req . args) (let* ((message (and (pair? args) (car args))) (extras (if (pair? args) (cdr args) '())) (generic-title (lambda (port) (title-html port - (status-code->text status-code)))) + (status-code-message code)))) (send-message (lambda (port) (if message (format port "
~%Further Information: ~A
~%" message)))) @@ -107,8 +102,8 @@ (create-response (lambda (headers writer-proc) - (make-response status-code - (status-code->text status-code) + (make-response code + #f (time) "text/html" headers @@ -117,8 +112,8 @@ (cond ;; This error response requires two args: message is the new URI: field, ;; and the first EXTRA is the older Location: field. - ((or (= status-code http-status/moved-temp) - (= status-code http-status/moved-perm)) + ((or (eq? code (status-code moved-temp)) + (eq? code (status-code moved-perm))) (create-response (list (cons 'uri message) (cons 'location (car extras))) @@ -126,11 +121,13 @@ (title-html port "Document moved") (format port "This document has ~A moved to a new location.~%" - (if (= status-code http-status/moved-temp) "temporarily" "permanently") + (if (eq? code (status-code moved-temp)) + "temporarily" + "permanently") message) (close-html port)))) - ((= status-code http-status/bad-request) + ((eq? code (status-code bad-request)) (create-response '() (lambda (port options) @@ -140,7 +137,7 @@ (send-message port) (close-html port)))) - ((= status-code http-status/unauthorized) + ((eq? code (status-code unauthorized)) (create-response (list (cons 'WWW-Authenticate message)) ; Vas is das? ;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47 @@ -152,7 +149,7 @@ (send-message port) (close-html port)))) - ((= status-code http-status/forbidden) + ((eq? code (status-code forbidden)) (create-response '() (lambda (port options) @@ -164,7 +161,7 @@ (send-message port) (close-html port)))) - ((= status-code http-status/not-found) + ((eq? code (status-code not-found)) (create-response '() (lambda (port options) @@ -175,8 +172,7 @@ (send-message port) (close-html port)))) - ((= status-code http-status/internal-error) - (http-syslog (syslog-level error) "internal-error: ~A" message) + ((eq? code (status-code internal-error)) (create-response '() (lambda (port options) @@ -191,7 +187,7 @@ the error, and time it occured.~%" (send-message port) (close-html port)))) - ((= status-code http-status/not-implemented) + ((eq? code (status-code not-implemented)) (create-response '() (lambda (port options) @@ -202,22 +198,13 @@ the requested method (~A).~%" (send-message port) (close-html port)))) - ((= status-code http-status/bad-gateway) + ((eq? code (status-code bad-gateway)) (create-response '() (lambda (port options) (generic-title port) (format port "An error occured while waiting for the response of a gateway.~%") - (send-message port) - (close-html port)))) - - (else - (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code) - (create-response - '() - (lambda (port options) - (generic-title port) (send-message port) (close-html port))))))) @@ -233,8 +220,8 @@ response of a gateway.~%") ;; NEW-LOCATION. NEW-LOCATION must be uri-encoded and begin with a slash. (define (make-redirect-response new-location) (make-response - http-status/redirect - (status-code->text http-status/redirect) + (status-code redirect) + #f (time) "" '() diff --git a/scheme/httpd/rman-gateway.scm b/scheme/httpd/rman-gateway.scm index 790dbe2..65e6acd 100644 --- a/scheme/httpd/rman-gateway.scm +++ b/scheme/httpd/rman-gateway.scm @@ -49,8 +49,8 @@ (decline)))) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() @@ -65,7 +65,7 @@ (with-tag out address () (display address out))))))) (else - (make-http-error-response http-status/method-not-allowed req + (make-http-error-response (status-code method-not-allowed) req request-method))))))) (define (cat-man-page key section out) @@ -128,7 +128,7 @@ (with-env (("MANPATH" . ,(string-join man-path ":"))) (run (,man-binary "-man" ,@(if section `(,section) '()) ,key) stdports)))) - (http-error http-status/not-found #f "man page not found"))))) + (http-error (status-code not-found) #f "man page not found"))))) (define man-default-sections '("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p")) @@ -187,4 +187,4 @@ (with-cwd (file->man-directory file) (exec-epf (,nroff-binary "-man"))))) stdports))) - (http-error http-status/not-found #f "man page not found"))) + (http-error (status-code not-found) #f "man page not found"))) diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm index 166a32e..d0a7dbc 100644 --- a/scheme/httpd/seval.scm +++ b/scheme/httpd/seval.scm @@ -47,12 +47,12 @@ ((string=? request-method "POST") ; Could do others also. (seval path req)) (else - (make-http-error-response http-status/method-not-allowed req request-method))))) + (make-http-error-response (status-code method-not-allowed) req request-method))))) (define (seval path req) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 44a49a2..227820e 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -92,15 +92,15 @@ (if (resume-url? path-string) (resume-url path-string servlet-path req) (launch-new-session path-string servlet-path req)) - (make-http-error-response http-status/method-not-allowed req + (make-http-error-response (status-code method-not-allowed) req request-method))) - (make-http-error-response http-status/bad-request req + (make-http-error-response (status-code bad-request) req (format #f "Bad path: ~s" path))))) (define (launch-new-session path-string servlet-path req) (cond ((file-not-exists? (absolute-file-name path-string servlet-path)) - (make-http-error-response http-status/not-found req path-string)) + (make-http-error-response (status-code not-found) req path-string)) ((string=? (file-name-extension path-string) ".scm") (obtain-lock *session-table-lock*) ;; no access to session table until new session-id is saved @@ -147,7 +147,7 @@ ; (send-file-response full-file-name ; (file-info full-file-name) ; req)) - (make-http-error-response http-status/forbidden req + (make-http-error-response (status-code forbidden) req "Can't serve other than Scheme files." path-string)) )) @@ -188,7 +188,7 @@ (let ((bad-request (lambda (path-string req) (make-http-error-response - http-status/bad-request req + (status-code bad-request) req (format #f "

There may be several reasons, why your request for a servlet was denied: @@ -247,7 +247,7 @@ continuation-counter continuation-id))) (response-maker new-url))))) - (make-http-error-response http-status/not-found #f + (make-http-error-response (status-code not-found) #f "The URL refers to a servlet, whose session is no longer alive."))))) (define (send/finish response) @@ -558,7 +558,7 @@ (define (bad-gateway-error-response req path-string condition) (make-http-error-response - http-status/bad-gateway req + (status-code bad-gateway) req (format #f "Error in servlet ~s." path-string) condition)) diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index 43c3517..02d852f 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/scheme/httpd/surflets/surflets.scm @@ -23,8 +23,8 @@ (define (make-usual-html-response writer-proc) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() @@ -99,7 +99,7 @@ (if first-digit (string->number (substring content-length first-digit content-length-len)) - ;; http-status/bad-request req + ;; (status-code bad-request) req `(error "Illegal `Content-length:' header."))))) (else (error "No Content-length specified for POST data.")))) diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm index 65a4a5b..0ee735c 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm @@ -50,7 +50,7 @@ (a (@ (href ,new-url)) "close this session"))))))) ;; How to clear session data and go to another HTML page: (send/finish - (make-http-error-response http-status/moved-temp req + (make-http-error-response (status-code moved-temp) req "/" "/")) )) ; )) diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm index 2843a88..37147c2 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm @@ -49,8 +49,8 @@ ))) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() @@ -77,8 +77,8 @@ (number->string (+ (get-number1) (get-number2))) new-url))) (make-response - http-status/ok - (status-code->text http-status/ok) + (status-code ok) + #f (time) "text/html" '() @@ -109,7 +109,7 @@ ;; This finishes the session and does a redirect to the root ;; page. (send/finish - (make-http-error-response http-status/moved-temp req + (make-http-error-response (status-code moved-temp) req "/" "/"))) )) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm index 1c4262d..de65b05 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm @@ -78,7 +78,7 @@ (define (return-to-main-page req) - (send/finish (make-http-error-response http-status/moved-perm req + (send/finish (make-http-error-response (status-code moved-perm) req "admin.scm" "admin.scm"))) (define (main req) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm index 39778c4..14b5031 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm @@ -204,7 +204,7 @@ plot '~a' title 'Servlet Profiling ~a' with lines" (return-to-main-page req)) (define (return-to-main-page req) - (send/finish (make-http-error-response http-status/moved-perm req + (send/finish (make-http-error-response (status-code moved-perm) req "admin.scm" "admin.scm"))) (define (main req) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm index 0b29baa..606f9b4 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm @@ -295,7 +295,7 @@ (map car continuations)))) (define (return-to-main-page req) - (send/finish (make-http-error-response http-status/moved-perm req + (send/finish (make-http-error-response (status-code moved-perm) req "admin.scm" "admin.scm"))) (define (main req) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm index 999e317..948475f 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm @@ -307,7 +307,7 @@ (map car continuations)))) (define (return-to-main-page req) - (send/finish (make-http-error-response http-status/moved-perm req + (send/finish (make-http-error-response (status-code moved-perm) req "admin.scm" "admin.scm"))) (define (main req) diff --git a/scheme/packages.scm b/scheme/packages.scm index d2a68c5..7f41b00 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -278,35 +278,10 @@ make-redirect-body redirect-body? redirect-body-location 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 - http-status/redirect ; used internally + status-code? + status-code-number + status-code-message + status-code make-http-error-response make-redirect-response @@ -617,6 +592,7 @@ uri ; uri-path-list->path url ; http-url-path httpd-requests ; request record + httpd-responses formats format-net ; format-internet-host-address (subset srfi-13 (string-join string-trim)) @@ -640,10 +616,9 @@ (subset scsh (format-date write-string time date)) syslog define-record-types - defenum-package + finite-types formats httpd-requests - httpd-logging httpd-read-options) (files (httpd response)))