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

Rename MAKE-HTTP-ERROR-RESPONSE -> MAKE-ERROR-RESPONSE to be 

consistent with MAKE-RESPONSE.
This commit is contained in:
sperber 2003-01-10 09:52:35 +00:00
parent 26de50f074
commit 86b0639a7f
16 changed files with 45 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -91,7 +91,7 @@
(lambda (path req) (lambda (path req)
(if (pair? path) ; Got to have at least one elt. (if (pair? path) ; Got to have at least one elt.
(compute-cgi path req bin-dir request-invariant-cgi-env) (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) (define (compute-cgi path req bin-dir request-invariant-cgi-env)
(let* ((prog (car path)) (let* ((prog (car path))
@ -124,23 +124,23 @@
(if nph? (if nph?
(let ((stat (wait (fork doit)))) (let ((stat (wait (fork doit))))
(if (not (zero? stat)) (if (not (zero? stat))
(make-http-error-response (make-error-response
(status-code bad-request) req (status-code bad-request) req
(format #f "Could not execute CGI script ~a." (format #f "Could not execute CGI script ~a."
filename)) filename))
stat)) ;; FIXME! must return http-response object! stat)) ;; FIXME! must return http-response object!
(case (file-not-executable? filename) (case (file-not-executable? filename)
((search-denied permission) ((search-denied permission)
(make-http-error-response (status-code forbidden) req (make-error-response (status-code forbidden) req
"Permission denied.")) "Permission denied."))
((no-directory nonexistent) ((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.")) "File or directory doesn't exist."))
(else (else
(cgi-make-response (run/port* doit) path req))))) (cgi-make-response (run/port* doit) path req)))))
(else (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) (define (split-and-decode-search-spec s)
@ -259,7 +259,7 @@
(if loc (if loc
(if (uri-has-protocol? (string-trim 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) loc loc)
(make-redirect-response (string-trim loc))) (make-redirect-response (string-trim loc)))
;; Send the response header back to the client ;; Send the response header back to the client

6
scheme/httpd/core.scm
View File

@ -142,13 +142,13 @@
((http-error? c) ((http-error? c)
(apply (lambda (status-code req . args) (apply (lambda (status-code req . args)
(values req (values req
(apply make-http-error-response (apply make-error-response
status-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 (status-code bad-request) (apply make-error-response (status-code 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))))
@ -158,7 +158,7 @@
;; try to send bug report to client ;; try to send bug report to client
(values #f (values #f
(apply make-http-error-response (status-code internal-error) (apply make-error-response (status-code internal-error)
#f ; don't know #f ; don't know
"Internal error occured while processing request" "Internal error occured while processing request"
c))) c)))

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

@ -25,7 +25,7 @@
(define (home-dir-handler user-public-dir) (define (home-dir-handler user-public-dir)
(lambda (path req) (lambda (path req)
(if (null? path) (if (null? path)
(make-http-error-response (status-code bad-request) (make-error-response (status-code bad-request)
req req
"Path contains no home directory.") "Path contains no home directory.")
(make-rooted-file-path-response (string-append (http-homedir (car path) req) (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) (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 (status-code bad-request) req (make-error-response (status-code 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 (status-code bad-request) req (make-error-response (status-code bad-request) req
"URL contains unresolvable ..'s."))))) "URL contains unresolvable ..'s.")))))
@ -153,16 +153,16 @@
(send-file-response fname info req)) (send-file-response fname info req))
((directory) ; Send back a redirection "foo" -> "foo/" ((directory) ; Send back a redirection "foo" -> "foo/"
(make-http-error-response (make-error-response
(status-code moved-perm) req (status-code 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 (status-code forbidden) req))))) (else (make-error-response (status-code forbidden) req)))))
(else (else
(make-http-error-response (status-code method-not-allowed) req (make-error-response (status-code method-not-allowed) req
request-method)))))) request-method))))))
(define (directory-index-serve-response fname file-path req) (define (directory-index-serve-response fname file-path req)
@ -360,7 +360,7 @@
(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 (status-code forbidden) req) (make-error-response (status-code forbidden) req)
(make-response (make-response
(status-code ok) (status-code ok)
#f #f
@ -405,7 +405,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 (status-code method-not-allowed) req (make-error-response (status-code method-not-allowed) req
request-method))))) request-method)))))
(define (index-or-directory-serve-response fname file-path req) (define (index-or-directory-serve-response fname file-path req)
@ -431,7 +431,7 @@
(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 (status-code not-found) req) (make-error-response (status-code 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 (status-code ok) (make-response (status-code ok)

2
scheme/httpd/handlers.scm
View File

@ -85,4 +85,4 @@
;;; Can be useful as the default in table-driven request handlers. ;;; Can be useful as the default in table-driven request handlers.
(define (null-request-handler path req) (define (null-request-handler path req)
(make-http-error-response (status-code not-found) req)) (make-error-response (status-code not-found) req))

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

@ -168,7 +168,7 @@
(write-string address out))))))) (write-string address out)))))))
(else (else
(make-http-error-response (status-code method-not-allowed) req (make-error-response (status-code method-not-allowed) req
request-method))))))) request-method)))))))
(define split-header-line (define split-header-line

4
scheme/httpd/response.scm
View File

@ -78,7 +78,7 @@
(redirect -301 "Internal redirect"))) (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. ;;; 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 ;;; even had a chance to parse and construct the request. This is only used
;;; for 400 BAD-REQUEST error report. ;;; 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))) (let* ((message (and (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '())) (extras (if (pair? args) (cdr args) '()))

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

@ -65,7 +65,7 @@
(with-tag out address () (with-tag out address ()
(display address out))))))) (display address out)))))))
(else (else
(make-http-error-response (status-code method-not-allowed) req (make-error-response (status-code method-not-allowed) req
request-method))))))) request-method)))))))
(define (cat-man-page key section out) (define (cat-man-page key section out)

2
scheme/httpd/seval.scm
View File

@ -47,7 +47,7 @@
((string=? request-method "POST") ; Could do others also. ((string=? request-method "POST") ; Could do others also.
(seval path req)) (seval path req))
(else (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) (define (seval path req)
(make-response (make-response

14
scheme/httpd/surflets/surflet-handler.scm
View File

@ -92,15 +92,15 @@
(if (resume-url? path-string) (if (resume-url? path-string)
(resume-url path-string servlet-path req) (resume-url path-string servlet-path req)
(launch-new-session 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))) 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))))) (format #f "Bad path: ~s" path)))))
(define (launch-new-session path-string servlet-path req) (define (launch-new-session path-string servlet-path req)
(cond (cond
((file-not-exists? (absolute-file-name path-string servlet-path)) ((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") ((string=? (file-name-extension path-string) ".scm")
(obtain-lock *session-table-lock*) (obtain-lock *session-table-lock*)
;; no access to session table until new session-id is saved ;; no access to session table until new session-id is saved
@ -147,7 +147,7 @@
; (send-file-response full-file-name ; (send-file-response full-file-name
; (file-info full-file-name) ; (file-info full-file-name)
; req)) ; req))
(make-http-error-response (status-code forbidden) req (make-error-response (status-code forbidden) req
"Can't serve other than Scheme files." "Can't serve other than Scheme files."
path-string)) path-string))
)) ))
@ -187,7 +187,7 @@
(define resume-url (define resume-url
(let ((bad-request (let ((bad-request
(lambda (path-string req) (lambda (path-string req)
(make-http-error-response (make-error-response
(status-code bad-request) req (status-code bad-request) req
(format #f (format #f
"<br> "<br>
@ -247,7 +247,7 @@
continuation-counter continuation-counter
continuation-id))) continuation-id)))
(response-maker new-url))))) (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."))))) "The URL refers to a servlet, whose session is no longer alive.")))))
(define (send/finish response) (define (send/finish response)
@ -557,7 +557,7 @@
(lambda () body ...))))) (lambda () body ...)))))
(define (bad-gateway-error-response req path-string condition) (define (bad-gateway-error-response req path-string condition)
(make-http-error-response (make-error-response
(status-code bad-gateway) req (status-code bad-gateway) req
(format #f "Error in servlet ~s." path-string) (format #f "Error in servlet ~s." path-string)
condition)) condition))

2
scheme/httpd/surflets/web-server/root/surflets/add-html.scm
View File

@ -50,7 +50,7 @@
(a (@ (href ,new-url)) "close this session"))))))) (a (@ (href ,new-url)) "close this session")))))))
;; How to clear session data and go to another HTML page: ;; How to clear session data and go to another HTML page:
(send/finish (send/finish
(make-http-error-response (status-code moved-temp) req (make-error-response (status-code moved-temp) req
"/" "/")) "/" "/"))
)) ))
; )) ; ))

2
scheme/httpd/surflets/web-server/root/surflets/add-raw.scm
View File

@ -109,7 +109,7 @@
;; This finishes the session and does a redirect to the root ;; This finishes the session and does a redirect to the root
;; page. ;; page.
(send/finish (send/finish
(make-http-error-response (status-code moved-temp) req (make-error-response (status-code moved-temp) req
"/" "/"))) "/" "/")))
)) ))

2
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -78,7 +78,7 @@
(define (return-to-main-page req) (define (return-to-main-page req)
(send/finish (make-http-error-response (status-code moved-perm) req (send/finish (make-error-response (status-code moved-perm) req
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)

2
scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
View File

@ -204,7 +204,7 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
(return-to-main-page req)) (return-to-main-page req))
(define (return-to-main-page req) (define (return-to-main-page req)
(send/finish (make-http-error-response (status-code moved-perm) req (send/finish (make-error-response (status-code moved-perm) req
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)

2
scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm
View File

@ -295,7 +295,7 @@
(map car continuations)))) (map car continuations))))
(define (return-to-main-page req) (define (return-to-main-page req)
(send/finish (make-http-error-response (status-code moved-perm) req (send/finish (make-error-response (status-code moved-perm) req
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)

2
scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
View File

@ -307,7 +307,7 @@
(map car continuations)))) (map car continuations))))
(define (return-to-main-page req) (define (return-to-main-page req)
(send/finish (make-http-error-response (status-code moved-perm) req (send/finish (make-error-response (status-code moved-perm) req
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)

2
scheme/packages.scm
View File

@ -283,7 +283,7 @@
status-code-message status-code-message
status-code status-code
make-http-error-response make-error-response
make-redirect-response make-redirect-response
time->http-date-string)) time->http-date-string))