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)))