diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index 693193d..e1407d0 100644 --- a/scheme/httpd/cgi-server.scm +++ b/scheme/httpd/cgi-server.scm @@ -91,7 +91,7 @@ (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 (status-code bad-request) req "Empty CGI script")))))) + (make-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)) @@ -124,23 +124,23 @@ (if nph? (let ((stat (wait (fork doit)))) (if (not (zero? stat)) - (make-http-error-response + (make-error-response (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 (status-code forbidden) req + (make-error-response (status-code forbidden) req "Permission denied.")) ((no-directory nonexistent) - (make-http-error-response (status-code not-found) req + (make-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 (status-code method-not-allowed) req request-method)))))) + (make-error-response (status-code method-not-allowed) req request-method)))))) (define (split-and-decode-search-spec s) @@ -259,7 +259,7 @@ (if loc (if (uri-has-protocol? (string-trim loc)) - (make-http-error-response (status-code moved-perm) req + (make-error-response (status-code moved-perm) req loc loc) (make-redirect-response (string-trim loc))) ;; Send the response header back to the client diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 646dbd5..044033c 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -142,13 +142,13 @@ ((http-error? c) (apply (lambda (status-code req . args) (values req - (apply make-http-error-response + (apply make-error-response status-code req args))) (condition-stuff c))) ((fatal-syntax-error? c) (values #f - (apply make-http-error-response (status-code bad-request) + (apply make-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 (status-code internal-error) + (apply make-error-response (status-code internal-error) #f ; don't know "Internal error occured while processing request" c))) diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm index 64ff9bd..4e6f22e 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 (status-code bad-request) + (make-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 (status-code bad-request) req + (make-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 (status-code bad-request) req + (make-error-response (status-code bad-request) req "URL contains unresolvable ..'s."))))) @@ -153,16 +153,16 @@ (send-file-response fname info req)) ((directory) ; Send back a redirection "foo" -> "foo/" - (make-http-error-response + (make-error-response (status-code moved-perm) req (string-append (request-uri req) "/") (string-append (http-url->string (request-url req)) "/"))) - (else (make-http-error-response (status-code forbidden) req))))) + (else (make-error-response (status-code forbidden) req))))) (else - (make-http-error-response (status-code method-not-allowed) req + (make-error-response (status-code method-not-allowed) req request-method)))))) (define (directory-index-serve-response fname file-path req) @@ -360,7 +360,7 @@ (if (not (eq? 'directory (file-info:type (file-info fname #t)))) - (make-http-error-response (status-code forbidden) req) + (make-error-response (status-code forbidden) req) (make-response (status-code ok) #f @@ -405,7 +405,7 @@ (emit-tag port 'hr) (format port "~d files" n-files)))))))))))) (else - (make-http-error-response (status-code method-not-allowed) req + (make-error-response (status-code method-not-allowed) req request-method))))) (define (index-or-directory-serve-response fname file-path req) @@ -431,7 +431,7 @@ (define (send-file-response filename info req) (if (file-not-readable? filename) ; #### double stats are no good - (make-http-error-response (status-code not-found) req) + (make-error-response (status-code not-found) req) (receive (stripped-filename content-encoding) (file-extension->content-encoding filename) (make-response (status-code ok) diff --git a/scheme/httpd/handlers.scm b/scheme/httpd/handlers.scm index 0b66ebd..0b29ac9 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 (status-code not-found) req)) + (make-error-response (status-code not-found) req)) diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm index 6ac8bd4..18a49ff 100644 --- a/scheme/httpd/info-gateway.scm +++ b/scheme/httpd/info-gateway.scm @@ -168,7 +168,7 @@ (write-string address out))))))) (else - (make-http-error-response (status-code method-not-allowed) req + (make-error-response (status-code method-not-allowed) req request-method))))))) (define split-header-line diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index e719411..88d622f 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -78,7 +78,7 @@ (redirect -301 "Internal redirect"))) -;;; (make-http-error-response status-code req [message . extras]) +;;; (make-error-response status-code req [message . extras]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Take an http-error condition, and format it into a response to the client. ;;; @@ -86,7 +86,7 @@ ;;; 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 code req . args) +(define (make-error-response code req . args) (let* ((message (and (pair? args) (car args))) (extras (if (pair? args) (cdr args) '())) @@ -225,4 +225,4 @@ response of a gateway.~%") (time) "" '() - (make-redirect-body new-location))) \ No newline at end of file + (make-redirect-body new-location))) diff --git a/scheme/httpd/rman-gateway.scm b/scheme/httpd/rman-gateway.scm index 65e6acd..b652846 100644 --- a/scheme/httpd/rman-gateway.scm +++ b/scheme/httpd/rman-gateway.scm @@ -65,7 +65,7 @@ (with-tag out address () (display address out))))))) (else - (make-http-error-response (status-code method-not-allowed) req + (make-error-response (status-code method-not-allowed) req request-method))))))) (define (cat-man-page key section out) diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm index d0a7dbc..7cf04ee 100644 --- a/scheme/httpd/seval.scm +++ b/scheme/httpd/seval.scm @@ -47,7 +47,7 @@ ((string=? request-method "POST") ; Could do others also. (seval path req)) (else - (make-http-error-response (status-code method-not-allowed) req request-method))))) + (make-error-response (status-code method-not-allowed) req request-method))))) (define (seval path req) (make-response diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 227820e..03cdba3 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 (status-code method-not-allowed) req + (make-error-response (status-code method-not-allowed) req request-method))) - (make-http-error-response (status-code bad-request) req + (make-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 (status-code not-found) req path-string)) + (make-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 (status-code forbidden) req + (make-error-response (status-code forbidden) req "Can't serve other than Scheme files." path-string)) )) @@ -187,7 +187,7 @@ (define resume-url (let ((bad-request (lambda (path-string req) - (make-http-error-response + (make-error-response (status-code bad-request) req (format #f "
@@ -247,7 +247,7 @@ continuation-counter continuation-id))) (response-maker new-url))))) - (make-http-error-response (status-code not-found) #f + (make-error-response (status-code not-found) #f "The URL refers to a servlet, whose session is no longer alive."))))) (define (send/finish response) @@ -557,7 +557,7 @@ (lambda () body ...))))) (define (bad-gateway-error-response req path-string condition) - (make-http-error-response + (make-error-response (status-code bad-gateway) req (format #f "Error in servlet ~s." path-string) condition)) 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 0ee735c..133b49d 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm @@ -50,8 +50,8 @@ (a (@ (href ,new-url)) "close this session"))))))) ;; How to clear session data and go to another HTML page: (send/finish - (make-http-error-response (status-code moved-temp) req - "/" "/")) + (make-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 37147c2..828db1c 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add-raw.scm @@ -109,8 +109,8 @@ ;; This finishes the session and does a redirect to the root ;; page. (send/finish - (make-http-error-response (status-code moved-temp) req - "/" "/"))) + (make-error-response (status-code moved-temp) req + "/" "/"))) )) \ No newline at end of file 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 de65b05..ab65425 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm @@ -78,8 +78,8 @@ (define (return-to-main-page req) - (send/finish (make-http-error-response (status-code moved-perm) req - "admin.scm" "admin.scm"))) + (send/finish (make-error-response (status-code moved-perm) req + "admin.scm" "admin.scm"))) (define (main req) (handler-options 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 14b5031..675f7e1 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm @@ -204,8 +204,8 @@ 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 (status-code moved-perm) req - "admin.scm" "admin.scm"))) + (send/finish (make-error-response (status-code moved-perm) req + "admin.scm" "admin.scm"))) (define (main req) ;; We'll fill this out soon. 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 606f9b4..434fd40 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,8 +295,8 @@ (map car continuations)))) (define (return-to-main-page req) - (send/finish (make-http-error-response (status-code moved-perm) req - "admin.scm" "admin.scm"))) + (send/finish (make-error-response (status-code moved-perm) req + "admin.scm" "admin.scm"))) (define (main req) (servlets 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 948475f..820885c 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm @@ -307,8 +307,8 @@ (map car continuations)))) (define (return-to-main-page req) - (send/finish (make-http-error-response (status-code moved-perm) req - "admin.scm" "admin.scm"))) + (send/finish (make-error-response (status-code moved-perm) req + "admin.scm" "admin.scm"))) (define (main req) (show-servlets req)) diff --git a/scheme/packages.scm b/scheme/packages.scm index 7f41b00..0daf7cc 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -283,7 +283,7 @@ status-code-message status-code - make-http-error-response + make-error-response make-redirect-response time->http-date-string))