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

-move XHTML stuff from responses.scm to htmlout.scm 

-don't use WRITE-STRING with \n (\n within strings is not in R5RS),
instead use FORMAT with ~%
-use EMIT-PROLOG and EMIT-TAG from htmlout.scm
This commit is contained in:
vibr 2004-08-13 15:37:31 +00:00
parent c089e26e96
commit 96f0ae41d5
1 changed files with 10 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
scheme/httpd/response.scm
View File

@ -164,7 +164,7 @@
(if (not (null? args)) (if (not (null? args))
(format port "<br/>~%Further Information:~%")) (format port "<br/>~%Further Information:~%"))
(for-each (lambda (x) (format port "<br/>~%~s~%" x)) args) (for-each (lambda (x) (format port "<br/>~%~s~%" x)) args)
(write-string "</p>\n</body>\n</html>\n" port))) (format port "</p>~%</body>~%</html>~%")))
(create-response (create-response
(lambda (headers writer-proc) (lambda (headers writer-proc)
@ -201,7 +201,7 @@
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(write-string "The request the client sent could not be understood by this server due to malformed syntax.\n Report to client maintainer.\n" port) (format port "The request the client sent could not be understood by this server due to malformed syntax.~% Report to client maintainer.~%")
(close-html port extras)))) (close-html port extras))))
;; This error response requires one arg: ;; This error response requires one arg:
@ -227,7 +227,7 @@
(list (cons 'WWW-Authenticate (car extras))) (list (cons 'WWW-Authenticate (car extras)))
(lambda (port options) (lambda (port options)
(title-html port "Authentication Required") (title-html port "Authentication Required")
(write-string "Client not authentication-capable or authentication failed.\n" port) (format port "Client not authentication-capable or authentication failed.~%")
(close-html port (cdr extras))))) (close-html port (cdr extras)))))
((eq? code (status-code forbidden)) ((eq? code (status-code forbidden))
@ -235,7 +235,7 @@
'() '()
(lambda (port options) (lambda (port options)
(title-html port "Request not allowed.") (title-html port "Request not allowed.")
(write-string "The request the client sent is not allowed.\n Retrying won't help.\n" port) (format port "The request the client sent is not allowed.~% Retrying won't help.~%")
(close-html port extras)))) (close-html port extras))))
((eq? code (status-code not-found)) ((eq? code (status-code not-found))
@ -243,7 +243,7 @@
'() '()
(lambda (port options) (lambda (port options)
(title-html port "Resource not found") (title-html port "Resource not found")
(format port "The requested resource ~A was not found on this server.\n" (format port "The requested resource ~A was not found on this server.~%"
(http-url->string (request-url req))) (http-url->string (request-url req)))
(close-html port extras)))) (close-html port extras))))
@ -262,7 +262,7 @@
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(format port "This server does not recognize or does not implement the requested method \"~A\".~%" (format port "This server does not recognize or does not implement the requested method ~A.~%"
(request-method req)) (request-method req))
(close-html port extras)))) (close-html port extras))))
@ -274,13 +274,12 @@
(format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%") (format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
(close-html port extras))))))) (close-html port extras)))))))
(define (title-html out message) (define (title-html out message)
;;produce valid XHTML 1.0 Strict ;;produce valid XHTML 1.0 Strict
(write-string (emit-prolog out)
"<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?> (emit-tag out 'html xmlnsdecl-attr)
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"> (format out "~%<head>~%<title>~%~A~%</title>~%</head>~%" message)
<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en\" xml:lang=\"en\">\n" out)
(format out "<head>~%<title>~%~A~%</title>~%</head>~%~%" message)
(format out "<body>~%<h1>~A</h1>~%<p>~%" message)) (format out "<body>~%<h1>~A</h1>~%<p>~%" message))
;; Creates a redirect response. The server will serve the new file ;; Creates a redirect response. The server will serve the new file