*** empty log message ***
This commit is contained in:
commit
01310403c1
|
@ -0,0 +1,28 @@
|
|||
# CVS default ignores begin
|
||||
tags
|
||||
TAGS
|
||||
.make.state
|
||||
.nse_depinfo
|
||||
*~
|
||||
\#*
|
||||
.#*
|
||||
,*
|
||||
_$*
|
||||
*$
|
||||
*.old
|
||||
*.bak
|
||||
*.BAK
|
||||
*.orig
|
||||
*.rej
|
||||
.del-*
|
||||
*.a
|
||||
*.olb
|
||||
*.o
|
||||
*.obj
|
||||
*.so
|
||||
*.exe
|
||||
*.Z
|
||||
*.elc
|
||||
*.ln
|
||||
core
|
||||
# CVS default ignores end
|
|
@ -0,0 +1,26 @@
|
|||
Copyright (c) 1995-2000 by Olin Shivers.
|
||||
Copyright (c) 1996-2000 by Mike Sperber
|
||||
Copyright (c) 1999-2000 by Martin Gasbichler.
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions
|
||||
are met:
|
||||
1. Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
2. Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the distribution.
|
||||
3. The name of the authors may not be used to endorse or promote products
|
||||
derived from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
@ -0,0 +1,27 @@
|
|||
1997-12-01 Michael Sperber [Mr. Preprocessor] <sperber@informatik.uni-tuebingen.de>
|
||||
|
||||
* smtp.scm, parse-forms.scm: now 0.5.1-conformant
|
||||
|
||||
Mon Dec 2 10:41:09 1996 Michael Sperber [Mr. Preprocessor] <sperber@informatik.uni-tuebingen.de>
|
||||
|
||||
* ChangeLog: released 1.0beta2.
|
||||
|
||||
* htmlout.scm: Added escape-html and emit-text.
|
||||
|
||||
* http-core.scm: Made maintainer, domain name, and port
|
||||
configurable.
|
||||
|
||||
* everything: Commented date routines back in.
|
||||
|
||||
* httpd-access-control.scm: New file. Provides rudimentary access
|
||||
control.
|
||||
|
||||
* httpd-basic-handlers.scm: Added directory index serving. See
|
||||
comments in that file and in su-httpd.txt.
|
||||
|
||||
* info-gateway.scm: Added GNU info gateway.
|
||||
|
||||
* everything: Things now work under scsh 0.4.4.
|
||||
|
||||
* ChangeLog: started this file.
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
The SU Net package, version 1.0
|
||||
===============================
|
||||
|
||||
This directory contains my code for doing Net hacking from Scheme/scsh.
|
||||
It includes:
|
||||
An smtp client library.
|
||||
Forge mail from the comfort of your own Scheme process.
|
||||
|
||||
rfc822 header library
|
||||
Read email-style headers. Useful in several contexts (smtp, http, etc.)
|
||||
|
||||
Simple structured HTML output library
|
||||
Balanced delimiters, etc. htmlout.scm.
|
||||
|
||||
HTTP server library
|
||||
This is a complete implementation of an HTTP 1.0 server.
|
||||
The server is very extensible, via a mechanism called "path handlers."
|
||||
The library includes other standalone libraries that may be of use:
|
||||
+ URI and URL parsers and unparsers.
|
||||
+ A library to help writing CGI scripts in Scheme.
|
||||
+ Server extensions for interfacing to CGI scripts.
|
||||
+ Server extensions for uploading Scheme code.
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
Note well:
|
||||
- You can't do serious programming in Scheme within the bounds of R4RS.
|
||||
I work in Scheme 48 and scsh. Every file does have a comment header
|
||||
describing its non-R4RS dependencies, should you decide to try porting
|
||||
it to another Scheme.
|
||||
|
||||
- Only simple documentation, but my code is written in my usual style --
|
||||
voluminously commented.
|
||||
|
||||
-Olin
|
||||
-------------------------------------------------------------------------------
|
||||
Note further:
|
||||
|
||||
The net package is currently being maintained by Mike Sperber
|
||||
<sperber@informatik.uni-tuebingen.de>.
|
||||
|
||||
My main focus for further development is on making the HTTP server
|
||||
into a realistic full-blown package, but I'll gladly accept patches
|
||||
and suggestions for the other parts of the net package.
|
||||
|
||||
-Mike
|
|
@ -0,0 +1,94 @@
|
|||
;;; NCSA's WWW Common Gateway Interface -- script-side code -*- Scheme -*-
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
|
||||
;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
|
||||
|
||||
;;; Imports and non-R4RS'isms
|
||||
;;; switch (control structure)
|
||||
;;; getenv read-string (scsh)
|
||||
;;; error
|
||||
;;; parse-html-form-query (parse-html-forms package)
|
||||
|
||||
|
||||
;;; This file provides routines to help you write programs in Scheme
|
||||
;;; that can interface to HTTP servers using the CGI program interface
|
||||
;;; to carry out HTTP transactions.
|
||||
|
||||
;;; Other files/packages that will be of help:
|
||||
;;; rfc822 For reading headers from entities.
|
||||
;;; uri url For parsing and unparsing these things. Also for generally
|
||||
;;; URI-decoding strings.
|
||||
;;; htmlout For generating HTML output.
|
||||
|
||||
;;; About HTML forms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This info is in fact independent of CGI, but important to know about,
|
||||
;;; as many CGI scripts are written for responding to forms-entry in
|
||||
;;; HTML browsers.
|
||||
;;;
|
||||
;;; The form's field data are turned into a single string, of the form
|
||||
;;; name=val&name=val
|
||||
;;; where the <name> and <val> parts are URI encoded to hide their
|
||||
;;; &, =, and + chars, among other things. After URI encoding, the
|
||||
;;; space chars are converted to + chars, just for fun. It is important
|
||||
;;; to encode the spaces this way, because the perfectly general %xx escape
|
||||
;;; mechanism might be insufficiently confusing. This variant encoding is
|
||||
;;; called "form-url encoding."
|
||||
;;;
|
||||
;;; If the form's method is POST,
|
||||
;;; Browser sends the form's field data in the entity block, e.g.,
|
||||
;;; "button=on&ans=yes". The request's Content-type: is application/
|
||||
;;; x-www-form-urlencoded, and the request's Content-length: is the
|
||||
;;; number of bytes in the form data.
|
||||
;;;
|
||||
;;; If the form's method is GET,
|
||||
;;; Browser sends the form's field data in the URL's <search> part.
|
||||
;;; (So the server will pass to the CGI script as $QUERY_STRING,
|
||||
;;; and perhaps also on in argv[]).
|
||||
;;;
|
||||
;;; In either case, the data is "form-url encoded" (as described above).
|
||||
|
||||
;;; ISINDEX queries:
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; (Likewise for ISINDEX URL queries from browsers.)
|
||||
;;; Browser url-form encodes the query (see above), which then becomes the
|
||||
;;; ?<search> part of the URI. (Hence the CGI script will split the individual
|
||||
;;; fields into argv[].)
|
||||
|
||||
|
||||
;;; CGI interface:
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
|
||||
;;; - If it contains no raw "=" chars, it is split at "+" chars. The
|
||||
;;; substrings are URI decoded, and become the elts of argv[]. You aren't
|
||||
;;; supposed to rely on this unless you are replying to ISINDEX queries.
|
||||
;;; - The CGI script is run with stdin hooked up to the socket. If it's going
|
||||
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
|
||||
;;; - A bunch of env vars are set with useful values.
|
||||
;;; - Entity block is passed to script on stdin;
|
||||
;;; script writes reply to stdout.
|
||||
;;; - If the script begins with "nph-" its output is the entire reply.
|
||||
;;; Otherwise, when it replies to the server, it sends back a special
|
||||
;;; little header that tells the server how to construct the real header
|
||||
;;; for the reply.
|
||||
;;; See the "spec" for further details.
|
||||
|
||||
|
||||
;;; (cgi-form-query)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Return the form data as an alist of decoded strings.
|
||||
;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist
|
||||
;;; (("button" . "on") ("reply" . "Oh, yes"))
|
||||
;;; This only works for GET and POST methods.
|
||||
|
||||
(define (cgi-form-query)
|
||||
(switch string=? (getenv "REQUEST_METHOD")
|
||||
|
||||
(("GET")
|
||||
(parse-html-form-query (getenv "QUERY_STRING")))
|
||||
|
||||
(("POST")
|
||||
(let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
|
||||
(parse-html-form-query (read-string nchars))))
|
||||
|
||||
(else (error "Method not handled.")))) ; Don't be calling me.
|
|
@ -0,0 +1,279 @@
|
|||
;;; Server support for NCSA's WWW Common Gateway Interface -*- Scheme -*-
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
|
||||
;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
|
||||
|
||||
;;; Imports and non-R4RS'isms
|
||||
;;; "\r" in string for carriage-return.
|
||||
;;; format
|
||||
;;; string hacks
|
||||
;;; URI, URL record structs, parsers, and unparsers
|
||||
;;; write-crlf
|
||||
;;; scsh syscalls
|
||||
;;; ? for COND
|
||||
;;; SWITCH conditional
|
||||
;;; RFC822 header parsing
|
||||
;;; HTTP request record structure
|
||||
;;; HTTP-ERROR & reply codes
|
||||
;;; Basic path handler support (for ncsa-handler)
|
||||
|
||||
;;; PROBLEMS:
|
||||
;;; - The handlers could be made -- closed over their parameters
|
||||
;;; (e.g., root vars, etc.)
|
||||
|
||||
;;; This code provides a path-handler for the HTTP server that implements
|
||||
;;; a CGI interface to external programs for doing HTTP transactions.
|
||||
|
||||
;;; About HTML forms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This info is in fact independent of CGI, but important to know about,
|
||||
;;; as many CGI scripts are written for responding to forms-entry in
|
||||
;;; HTML browsers.
|
||||
;;;
|
||||
;;; The form's field data are turned into a single string, of the form
|
||||
;;; name=val&name=val
|
||||
;;; where the <name> and <val> parts are URI encoded to hide their
|
||||
;;; &, =, and + chars, among other things. After URI encoding, the
|
||||
;;; space chars are converted to + chars, just for fun. It is important
|
||||
;;; to encode the spaces this way, because the perfectly general %xx escape
|
||||
;;; mechanism might be insufficiently confusing. This variant encoding is
|
||||
;;; called "form-url encoding."
|
||||
;;;
|
||||
;;; If the form's method is POST,
|
||||
;;; Browser sends the form's field data in the entity block, e.g.,
|
||||
;;; "button=on&ans=yes". The request's Content-type: is application/
|
||||
;;; x-www-form-urlencoded, and the request's Content-length: is the
|
||||
;;; number of bytes in the form data.
|
||||
;;;
|
||||
;;; If the form's method is GET,
|
||||
;;; Browser sends the form's field data in the URL's <search> part.
|
||||
;;; (So the server will pass to the CGI script as $QUERY_STRING,
|
||||
;;; and perhaps also on in argv[]).
|
||||
;;;
|
||||
;;; In either case, the data is "form-url encoded" (as described above).
|
||||
|
||||
;;; ISINDEX queries:
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; (Likewise for ISINDEX URL queries from browsers.)
|
||||
;;; Browser url-form encodes the query (see above), which then becomes the
|
||||
;;; ?<search> part of the URI. (Hence the CGI script will split the individual
|
||||
;;; fields into argv[].)
|
||||
|
||||
|
||||
;;; CGI interface:
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
|
||||
;;; - If it contains no raw "=" chars, it is split at "+" chars. The
|
||||
;;; substrings are URI decoded, and become the elts of argv[].
|
||||
;;; - The CGI script is run with stdin hooked up to the socket. If it's going
|
||||
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
|
||||
;;; - A bunch of env vars are set; see below.
|
||||
;;; - If the script begins with "nph-" its output is the entire reply.
|
||||
;;; Otherwise, it replies to the server, we peel off a little header
|
||||
;;; that is used to construct the real header for the reply.
|
||||
;;; See the "spec" for further details.
|
||||
;;;
|
||||
;;; The "spec" also talks about PUT, but when I tried this on a dummy script,
|
||||
;;; the NSCA httpd server generated buggy output. So I am only implementing
|
||||
;;; the POST and GET ops; any other op generates a "405 Method not allowed"
|
||||
;;; reply.
|
||||
|
||||
;;; Parameters
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; path for scripts
|
||||
(define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
|
||||
|
||||
|
||||
;;; The path handler for CGI scripts. (car path) is the script to run.
|
||||
|
||||
(define (cgi-handler bin-dir)
|
||||
(lambda (path req)
|
||||
(if (pair? path) ; Got to have at least one elt.
|
||||
(let* ((prog (car path))
|
||||
|
||||
(filename (or (dotdot-check bin-dir (list prog))
|
||||
(http-error http-reply/bad-request req
|
||||
(format #f "CGI scripts may not contain \"..\" elements."))))
|
||||
|
||||
(nph? (string-suffix? "-nph" prog)) ; PROG end in "-nph" ?
|
||||
|
||||
(search (http-url:search (request:url req))) ; Compute the
|
||||
(argv (if (and search (not (index search #\=))) ; argv list.
|
||||
(split-and-decode-search-spec search)
|
||||
'()))
|
||||
|
||||
(env (cgi-env req bin-dir (cdr path)))
|
||||
|
||||
(doit (lambda ()
|
||||
(apply exec/env filename env argv)
|
||||
(http-error http-reply/bad-request req
|
||||
(format #f "Could not execute CGI script ~a."
|
||||
filename)))))
|
||||
|
||||
(http-log "search: ~s, argv: ~s~%" search argv)
|
||||
(switch string=? (request:method req)
|
||||
(("GET" "POST") ; Could do others also.
|
||||
(if nph?
|
||||
(wait (fork doit))
|
||||
(cgi-send-reply (run/port* doit) req)))
|
||||
|
||||
(else (http-error http-reply/method-not-allowed req))))
|
||||
|
||||
(http-error http-reply/bad-request req "Empty CGI script"))))
|
||||
|
||||
|
||||
(define (split-and-decode-search-spec s)
|
||||
(let recur ((i 0))
|
||||
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||
(recur (+ j 1)))))
|
||||
(else (list (unescape-uri s i (string-length s)))))))
|
||||
|
||||
|
||||
;;; Compute the CGI scripts' process environment by adding the standard CGI
|
||||
;;; environment var bindings to the current process env -- return result
|
||||
;;; as an alist.
|
||||
;;;
|
||||
;;; You are also supposed to add the headers as env vars in a particular
|
||||
;;; format, but are allowed to bag it if the environment var storage
|
||||
;;; requirements might overload the OS. I don't know what you can rely upon
|
||||
;;; in Unix, so I am just bagging it, period.
|
||||
;;;
|
||||
;;; Suppose the URL is
|
||||
;;; //machine/cgi-bin/test-script/foo/bar?quux%20a+b=c
|
||||
;;; then:
|
||||
;;; PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
|
||||
;;; PATH_TRANSLATED -- non-virtual version of above. "/u/Web/foo/bar/"
|
||||
;;; SCRIPT_NAME virtual path to script "/cgi-bin/test-script"
|
||||
;;; QUERY_STRING -- not decoded "quux%20a+b=c"
|
||||
;;; The first three of these vars are *not* encoded, so information is lost
|
||||
;;; if the URL's path elements contain encoded /'s (%2F). CGI loses.
|
||||
|
||||
(define (cgi-env req bin-dir path-suffix)
|
||||
(let* ((sock (request:socket req))
|
||||
(raddr (socket-remote-address sock))
|
||||
|
||||
(headers (request:headers req))
|
||||
|
||||
;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
|
||||
(path-info (uri-path-list->path path-suffix)) ; No encode or .. check.
|
||||
(path-translated (path-list->file-name path-info bin-dir))
|
||||
|
||||
;; Compute the $SCRIPT_PATH string.
|
||||
(url-path (http-url:path (request:url req)))
|
||||
(script-path (take (- (length url-path) (length path-suffix))
|
||||
url-path))
|
||||
(script-name (uri-path-list->path script-path)))
|
||||
|
||||
(if (not request-invariant-cgi-env)
|
||||
(initialise-request-invariant-cgi-env))
|
||||
|
||||
(receive (rhost rport)
|
||||
(socket-address->internet-address raddr)
|
||||
(receive (lhost lport)
|
||||
(socket-address->internet-address (socket-local-address sock))
|
||||
|
||||
`(("SERVER_PROTOCOL" . ,(version->string (request:version req)))
|
||||
("SERVER_PORT" . ,(number->string lport))
|
||||
("REQUEST_METHOD" . ,(request:method req))
|
||||
|
||||
("PATH_INFO" . ,path-info)
|
||||
("PATH_TRANSLATED" . ,path-translated)
|
||||
("SCRIPT_NAME" . ,script-name)
|
||||
|
||||
("REMOTE_HOST" . ,(host-info:name (host-info raddr)))
|
||||
("REMOTE_ADDR" . ,(internet-address->dotted-string rhost))
|
||||
|
||||
;; ("AUTH_TYPE" . xx) ; Random authentication
|
||||
;; ("REMOTE_USER" . xx) ; features I don't understand.
|
||||
;; ("REMOTE_IDENT" . xx)
|
||||
|
||||
,@request-invariant-cgi-env ; Stuff that never changes (see below).
|
||||
|
||||
,@(? ((http-url:search (request:url req)) =>
|
||||
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
||||
(else '()))
|
||||
|
||||
,@(? ((get-header headers 'content-type) =>
|
||||
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
|
||||
(else '()))
|
||||
|
||||
,@(? ((get-header headers 'content-length) =>
|
||||
(lambda (cl) ; Skip initial whitespace (& other non-digits).
|
||||
(let ((first-digit (char-set-index cl char-set:numeric))
|
||||
(cl-len (string-length cl)))
|
||||
(if first-digit
|
||||
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
|
||||
(http-error http-reply/bad-request
|
||||
req
|
||||
"Illegal Content-length: header.")))))
|
||||
|
||||
(else '()))
|
||||
|
||||
. ,(env->alist))))))
|
||||
|
||||
(define request-invariant-cgi-env #f)
|
||||
(define (initialise-request-invariant-cgi-env)
|
||||
(set! request-invariant-cgi-env
|
||||
`(("PATH" . ,(and (getenv "PATH") cgi-default-bin-path))
|
||||
("SERVER_SOFTWARE" . ,server/version)
|
||||
("SERVER_NAME" . ,(host-info:name (host-info (system-name))))
|
||||
("GATEWAY_INTERFACE" . "CGI/1.1"))))
|
||||
|
||||
|
||||
(define (take n lis)
|
||||
(if (zero? n) '()
|
||||
(cons (car lis) (take (- n 1) (cdr lis)))))
|
||||
|
||||
(define (drop n lis)
|
||||
(if (zero? n) lis
|
||||
(drop (- n 1) (cdr lis))))
|
||||
|
||||
|
||||
;;; Script's output for request REQ is available on SCRIPT-PORT.
|
||||
;;; The script isn't an "nph-" script, so we read the reply, and mutate
|
||||
;;; it into a real HTTP reply, which we then send back to the HTTP client.
|
||||
|
||||
(define (cgi-send-reply script-port req)
|
||||
(let* ((headers (read-rfc822-headers script-port))
|
||||
(ctype (get-header headers 'content-type)) ; The script headers
|
||||
(loc (get-header headers 'location))
|
||||
(stat (let ((stat-lines (get-header-lines headers 'status)))
|
||||
(? ((not (pair? stat-lines)) ; No status header.
|
||||
"200 The idiot CGI script left out the status line.")
|
||||
((null? (cdr stat-lines)) ; One line status header.
|
||||
(car stat-lines))
|
||||
(else ; Vas ist das?
|
||||
(http-error http-reply/internal-error req
|
||||
"CGI script generated multi-line status header")))))
|
||||
(out (current-output-port)))
|
||||
|
||||
(http-log "headers: ~s~%" headers)
|
||||
;; Send the reply header back to the client
|
||||
;; (unless it's a headerless HTTP 0.9 reply).
|
||||
(unless (v0.9-request? req)
|
||||
(format out "HTTP/1.0 ~a\r~%" stat)
|
||||
(if ctype (format out "Content-type: ~a\r~%" ctype))
|
||||
(if loc (format out "Location: ~a\r~%" loc))
|
||||
(write-crlf out))
|
||||
|
||||
(http-log "request:method=~a~%" (request:method req))
|
||||
;; Copy the reply body back to the client and close the script port
|
||||
;; (unless it's a bodiless HEAD transaction).
|
||||
(unless (string=? (request:method req) "HEAD")
|
||||
(copy-inport->outport script-port out)
|
||||
(close-input-port script-port))))
|
||||
|
||||
|
||||
;;; This proc and its inverse should be in a general IP module.
|
||||
|
||||
(define (internet-address->dotted-string num32)
|
||||
(let* ((num24 (arithmetic-shift num32 -8))
|
||||
(num16 (arithmetic-shift num24 -8))
|
||||
(num08 (arithmetic-shift num16 -8))
|
||||
(byte0 (bitwise-and #b11111111 num08))
|
||||
(byte1 (bitwise-and #b11111111 num16))
|
||||
(byte2 (bitwise-and #b11111111 num24))
|
||||
(byte3 (bitwise-and #b11111111 num32)))
|
||||
(string-append (number->string byte0) "." (number->string byte1) "."
|
||||
(number->string byte2) "." (number->string byte3))))
|
|
@ -0,0 +1,98 @@
|
|||
;;; handy syntax
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax when
|
||||
(syntax-rules ()
|
||||
((when bool body1 body2 ...)
|
||||
(if bool (begin body1 body2 ...)))))
|
||||
|
||||
|
||||
(define-syntax unless
|
||||
(syntax-rules ()
|
||||
((unless bool body1 body2 ...)
|
||||
(if (not bool) (begin body1 body2 ...)))))
|
||||
|
||||
(define-syntax ? ; ? is synonym for COND.
|
||||
(syntax-rules ()
|
||||
((? clause ...) (cond clause ...))))
|
||||
|
||||
|
||||
;;; Like CASE, but you specify the key-comparison procedure.
|
||||
;;; SWITCH evaluates its keys each time through the conditional.
|
||||
;;; SWITCHQ keys are not evaluated -- are simply constants.
|
||||
;;; (switchq string=? (vector-ref vec i)
|
||||
;;; (("plus" "minus") ...)
|
||||
;;; (("times" "div") ...)
|
||||
;;; (else ...))
|
||||
|
||||
(define-syntax switchq
|
||||
(syntax-rules ()
|
||||
((switchq compare key clause ...)
|
||||
(let ((k key) ; Eval KEY and COMPARE
|
||||
(c compare)) ; just once, then call %switch.
|
||||
(%switchq c k clause ...))))) ; C, K are vars, hence replicable.
|
||||
|
||||
(define-syntax %switchq
|
||||
(syntax-rules (else)
|
||||
((%switchq compare key ((key1 ...) body1 body2 ...) rest ...)
|
||||
(if (or (compare key 'key1) ...)
|
||||
(begin body1 body2 ...)
|
||||
(%switchq compare key rest ...)))
|
||||
|
||||
((%switchq compare key ((key1 ...)) rest ...) ; Null body.
|
||||
(if (not (or (compare key 'key1) ...))
|
||||
(%switchq compare key rest ...)))
|
||||
|
||||
((%switchq compare key (else body ...))
|
||||
(begin body ...))
|
||||
|
||||
((%switchq compare key) '#f)))
|
||||
|
||||
|
||||
(define-syntax switch
|
||||
(syntax-rules ()
|
||||
((switch compare key clause ...)
|
||||
(let ((k key) ; Eval KEY and COMPARE
|
||||
(c compare)) ; just once, then call %switch.
|
||||
(%switch c k clause ...))))) ; C, K are vars, hence replicable.
|
||||
|
||||
(define-syntax %switch
|
||||
(syntax-rules (else)
|
||||
((%switch compare key ((key1 ...) body1 body2 ...) rest ...)
|
||||
(if (or (compare key key1) ...)
|
||||
(begin body1 body2 ...)
|
||||
(%switch compare key rest ...)))
|
||||
|
||||
((%switch compare key ((key1 ...)) rest ...) ; Null body.
|
||||
(if (not (or (compare key key1) ...))
|
||||
(%switch compare key rest ...)))
|
||||
|
||||
((%switch compare key (else body ...))
|
||||
(begin body ...))
|
||||
|
||||
((%switch compare key) '#f)))
|
||||
|
||||
;;; I can't get this to work -- S48 complains "too many ...'s".
|
||||
;(define-syntax switchq
|
||||
; (syntax-rules (else)
|
||||
; ((switchq compare key clause ...)
|
||||
; (letrec-syntax ((%switchq (syntax-rules (else)
|
||||
; ((%switchq compare key
|
||||
; ((key1 ...) body1 body2 ...) rest ...)
|
||||
; (if (or (compare key 'key1) ...)
|
||||
; (begin body1 body2 ...)
|
||||
; (%switchq compare key rest ...)))
|
||||
;
|
||||
; ; Null body.
|
||||
; ((%switchq compare key ((key1 ...)) rest ...)
|
||||
; (if (not (or (compare key 'key1) ...))
|
||||
; (%switchq compare key rest ...)))
|
||||
;
|
||||
; ((%switchq compare key (else body ...))
|
||||
; (begin body ...))
|
||||
;
|
||||
; ((%switchq compare key) '#f))))
|
||||
;
|
||||
; (let ((k key) ; Eval KEY and COMPARE
|
||||
; (c compare)) ; just once, then call %switch.
|
||||
; (%switchq c k clause ...)))))); C, K are vars, hence replicable.
|
|
@ -0,0 +1,39 @@
|
|||
;;; Read cr/lf and lf terminated lines. -*- Scheme -*-
|
||||
;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
|
||||
|
||||
;;; External dependencies and non-R4RS'isms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ascii->char (To create a carriage-return)
|
||||
;;; read-line write-string force-output (scsh I/O procs)
|
||||
;;; receive values (MV return)
|
||||
;;; let-optionals
|
||||
;;; "\r\n" in strings for cr/lf. (Not R4RS)
|
||||
|
||||
;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Read a line terminated by either line-feed or EOF. If RETAIN-CRLF? is #f
|
||||
;;; (the default), a terminating cr/lf or lf sequence is trimmed from the
|
||||
;;; returned string.
|
||||
;;;
|
||||
;;; This is simple and inefficient. It would be save one copy if we didn't
|
||||
;;; use READ-LINE, but replicated its implementation instead.
|
||||
|
||||
(define (read-crlf-line . args)
|
||||
(let-optionals args ((fd/port (current-input-port))
|
||||
(retain-crlf? #f))
|
||||
(let ((ln (read-line fd/port retain-crlf?)))
|
||||
(if (or retain-crlf? (eof-object? ln))
|
||||
ln
|
||||
(let ((slen (string-length ln))) ; Trim a trailing cr, if any.
|
||||
(if (or (zero? slen)
|
||||
(not (char=? (string-ref ln (- slen 1)) cr)))
|
||||
ln
|
||||
(substring ln 0 (- slen 1))))))))
|
||||
|
||||
(define cr (ascii->char 13))
|
||||
|
||||
(define (write-crlf port)
|
||||
(write-string "\r\n" port)
|
||||
(force-output port))
|
||||
|
||||
|
|
@ -0,0 +1,196 @@
|
|||
;;; Simple code for doing structured html output. -*- Scheme -*-
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
|
||||
;;; External dependencies
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; format ; Output
|
||||
;;; receive values ; Multiple-value return
|
||||
|
||||
;;; - An attribute-quoter, that will map an attribute value to its
|
||||
;;; HTML text representation -- surrounding it with single or double quotes,
|
||||
;;; as appropriate, etc.
|
||||
|
||||
;;; Printing HTML tags.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; All the emit-foo procedures have the same basic calling conventions:
|
||||
;;; (emit-foo out <required values> ... [<extra attributes> ...])
|
||||
;;; - OUT is either a port or #t for the current input port.
|
||||
;;; - Each attribute is either a (name . value) pair, which is printed as
|
||||
;;; name="value"
|
||||
;;; or a single symbol or string, which is simply printed as-is
|
||||
;;; (this is useful for attributes that don't have values, such as the
|
||||
;;; ISMAP attribute in <img> tags).
|
||||
|
||||
|
||||
|
||||
;;; <tag name1="val1" name2="val2" ...>
|
||||
|
||||
(define (emit-tag out tag . attrs)
|
||||
(let ((out (if (eq? out #t) (current-output-port) out)))
|
||||
(display "<" out)
|
||||
(display tag out)
|
||||
(for-each (lambda (attr)
|
||||
(display #\space out)
|
||||
(cond ((pair? attr) ; name="val"
|
||||
(display (car attr) out)
|
||||
(display "=\"" out) ; Should check for
|
||||
(display (cdr attr) out) ; internal double-quote
|
||||
(display #\" out)) ; etc.
|
||||
(else
|
||||
(display attr out)))) ; name
|
||||
attrs)
|
||||
(display #\> out)))
|
||||
|
||||
|
||||
;;; </tag>
|
||||
|
||||
(define (emit-close-tag out tag)
|
||||
(format out "</~a>" tag))
|
||||
|
||||
|
||||
;;; <P>
|
||||
|
||||
(define (emit-p . args) ; (emit-p [out attr1 ...])
|
||||
(receive (out attrs) (if (pair? args)
|
||||
(let* ((out (car args)))
|
||||
(values (if (eq? out #t) (current-output-port) out)
|
||||
(cdr args)))
|
||||
(values (current-output-port) args))
|
||||
|
||||
(apply emit-tag out 'p attrs)
|
||||
(newline out)
|
||||
(newline out)))
|
||||
|
||||
|
||||
;;; <TITLE> Make Money Fast!!! </TITLE>
|
||||
|
||||
(define (emit-title out title) ; Takes no attributes.
|
||||
(format out "<title>~a~%</title>~%" title))
|
||||
|
||||
(define (emit-header out level text . attribs)
|
||||
(apply with-tag* out (string-append "H" (number->string level))
|
||||
(lambda () (display text (fmt->port out)))
|
||||
attribs))
|
||||
|
||||
;;; ...and so forth. Could stand to define a bunch of little emitters for the
|
||||
;;; various tags. (define-tag-emitter ...)
|
||||
|
||||
|
||||
;;; Printing out balanced <tag> ... </tag> pairs.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; (with-tag out tag (attr-elt ...) body ...)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Execute the body forms between a <tag attrs> ... </tag> pair.
|
||||
;;; The (ATTR-ELT ...) list specifies the attributes for the <tag>.
|
||||
;;; It is rather like a LET-list, having the form
|
||||
;;; ((name val) ...)
|
||||
;;; Each NAME must be a symbol, and each VAL must be a Scheme expression
|
||||
;;; whose value is the string to use as attribute NAME's value. Attributes
|
||||
;;; that have no value (e.g., ISMAP) can be specified as attr-elt NAME,
|
||||
;;; instead of (NAME VALUE).
|
||||
;;;
|
||||
;;; For example,
|
||||
;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page.
|
||||
;;; (with-tag port A ((href hp-url) (name "hp"))
|
||||
;;; (display "home page" port)))
|
||||
;;; outputs
|
||||
;;; <A href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</A>
|
||||
|
||||
(define-syntax with-tag
|
||||
(syntax-rules ()
|
||||
((with-tag out tag (attr-elt ...) body ...)
|
||||
(with-tag* out 'tag (lambda () body ...)
|
||||
(%hack-attr-elt attr-elt)
|
||||
...))))
|
||||
|
||||
;;; Why does this have to be top-level?
|
||||
;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
|
||||
|
||||
(define-syntax %hack-attr-elt
|
||||
(syntax-rules () ; Build attribute-list element:
|
||||
((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt)
|
||||
(cons 'name val))
|
||||
((%hack-attr-elt name) 'name))) ; name => 'name
|
||||
|
||||
|
||||
;;; Execute THUNK between a <tag attrs> ... </tag> pair.
|
||||
|
||||
(define (with-tag* out tag thunk . attrs)
|
||||
(apply emit-tag out tag attrs)
|
||||
(call-with-values thunk
|
||||
(lambda results
|
||||
(emit-close-tag out tag)
|
||||
(apply values results))))
|
||||
|
||||
|
||||
(define (fmt->port x)
|
||||
(if (eq? x #t) (current-output-port) x))
|
||||
|
||||
;;; Translate text to HTML, mapping special chars such as <, >, &, and
|
||||
;;; double-quote to their HTML escape sequences.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
||||
;; This is fairly simple-minded
|
||||
|
||||
;; Note iso8859-1 above 127 is perfectly OK
|
||||
|
||||
(define *html-entity-alist*
|
||||
(list
|
||||
(cons (ascii->char 60) "<")
|
||||
(cons (ascii->char 62) ">")
|
||||
(cons (ascii->char 38) "&")
|
||||
(cons (ascii->char 34) """)))
|
||||
|
||||
(define *html-entities*
|
||||
(chars->char-set (map car *html-entity-alist*)))
|
||||
|
||||
(define *html-entity-table*
|
||||
(let ((v (make-vector 256 #f)))
|
||||
(for-each (lambda (entry)
|
||||
(vector-set! v
|
||||
(char->ascii (car entry))
|
||||
(cdr entry)))
|
||||
*html-entity-alist*)
|
||||
v))
|
||||
|
||||
(define (string-set-substring! t start s)
|
||||
(let* ((l (string-length s))
|
||||
(end (+ l start)))
|
||||
(do ((i start (+ 1 i)))
|
||||
((= i end) t)
|
||||
(string-set! t i (string-ref s (- i start))))))
|
||||
|
||||
(define (escape-html s)
|
||||
(let ((target-length
|
||||
(string-reduce 0
|
||||
(lambda (c i)
|
||||
(+ i
|
||||
(if (char-set-contains? *html-entities* c)
|
||||
(string-length
|
||||
(vector-ref *html-entity-table*
|
||||
(char->ascii c)))
|
||||
1)))
|
||||
s)))
|
||||
(if (= target-length (string-length s))
|
||||
s
|
||||
(let ((target (make-string target-length)))
|
||||
(string-reduce
|
||||
0
|
||||
(lambda (c i)
|
||||
(+ i
|
||||
(if (char-set-contains? *html-entities* c)
|
||||
(let ((entity (vector-ref *html-entity-table* (char->ascii c))))
|
||||
(string-set-substring! target i entity)
|
||||
(string-length entity))
|
||||
(begin
|
||||
(string-set! target i c)
|
||||
1))))
|
||||
s)
|
||||
target))))
|
||||
|
||||
(define (emit-text s . maybe-port)
|
||||
(if (null? maybe-port)
|
||||
(write-string (escape-html s))
|
||||
(write-string (escape-html s) (car maybe-port))))
|
|
@ -0,0 +1,58 @@
|
|||
;;; Scheme Underground Web Server -*- Scheme -*-
|
||||
;;; Olin Shivers
|
||||
|
||||
;;; This file contains a few example top-level path-handlers and
|
||||
;;; other useful fragments.
|
||||
|
||||
;;; We import procedures from these structures:
|
||||
;;; httpd-core
|
||||
;;; cgi-server-package
|
||||
;;; httpd-basic-handlers
|
||||
;;; seval-handler-package
|
||||
|
||||
|
||||
;;; - /h/<user>/<file-path> => serve <file-path> from ~user/public_html.
|
||||
;;; - /seval You may POST Scheme code to this URL, and receive the output.
|
||||
;;; - Otherwise, serve files from the standard HTTP demon repository.
|
||||
|
||||
(define ph1
|
||||
(alist-path-dispatcher
|
||||
`(("h" . ,(home-dir-handler "public_html"))
|
||||
("seval" . ,seval-handler)
|
||||
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
|
||||
(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
|
||||
|
||||
|
||||
;;; Do a rough approximation of NCSA httpd server semantics:
|
||||
;;; - /~shivers/... serves file ~shivers/public_html/...
|
||||
;;; - /cgi-bin/<prog> passes control to script
|
||||
;;; /usr/local/etc/httpd/cgi-bin/<prog>
|
||||
;;; - Otherwise, just serve files out of the standard directory.
|
||||
|
||||
(define ph2
|
||||
(alist-path-dispatcher
|
||||
`(("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
|
||||
(tilde-home-dir-handler "public_html"
|
||||
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
|
||||
|
||||
;;; Greatest hits path handler.
|
||||
|
||||
(define ph3
|
||||
(alist-path-dispatcher
|
||||
`(("h" . ,(home-dir-handler "public_html"))
|
||||
("seval" . ,seval-handler)
|
||||
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
|
||||
(tilde-home-dir-handler "public_html"
|
||||
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
|
||||
|
||||
|
||||
|
||||
;;; Crank up a server on port 8001, first resetting our identity to
|
||||
;;; user "nobody". Initialise the request-invariant part of the CGI
|
||||
;;; env before starting.
|
||||
|
||||
(define (httpd1)
|
||||
(set-gid -2) ; Should be (set-uid (->uid "nobody"))
|
||||
(set-uid -2) ; but NeXTSTEP loses.
|
||||
(initialise-request-invariant-cgi-env)
|
||||
(httpd ph 8001 "/usr/local/etc/httpd/htdocs"))
|
|
@ -0,0 +1,77 @@
|
|||
;;; http server in the Scheme Shell -*- Scheme -*-
|
||||
;;; Access control
|
||||
;;; Copyright (c) 1996 by Mike Sperber. <sperber@informatik.uni-tuebingen.de>
|
||||
|
||||
;;; This code is very rudimentary at the moment and up for some expansion.
|
||||
;;; Right now, it is primarily useful for running the server through a
|
||||
;;; web accelerator
|
||||
|
||||
;;; Also notes that this code doesn't work in vanilla 0.4.4 as
|
||||
;;; host-info is broken.
|
||||
|
||||
(define (access-denier . hosts)
|
||||
(lambda (info)
|
||||
(and (any? (lambda (host)
|
||||
(host-matches? info host))
|
||||
hosts)
|
||||
'deny)))
|
||||
|
||||
(define (access-allower . hosts)
|
||||
(lambda (info)
|
||||
(and (any? (lambda (host)
|
||||
(host-matches? info host))
|
||||
hosts)
|
||||
'allow)))
|
||||
|
||||
(define (access-controller . controls)
|
||||
(lambda (info)
|
||||
(let loop ((controls controls))
|
||||
(if (null? controls)
|
||||
#f
|
||||
(cond
|
||||
(((car controls) info) => identity)
|
||||
(else (loop (cdr controls))))))))
|
||||
|
||||
(define (access-controlled-handler control ph)
|
||||
(lambda (path req)
|
||||
(if (eq?
|
||||
(control (host-info (socket-remote-address (request:socket req))))
|
||||
'deny)
|
||||
(http-error http-reply/forbidden req)
|
||||
(ph path req))))
|
||||
|
||||
(define (address->list address)
|
||||
(list (arithmetic-shift (bitwise-and address #xff000000) -24)
|
||||
(arithmetic-shift (bitwise-and address #xff0000) -16)
|
||||
(arithmetic-shift (bitwise-and address #xff00) -8)
|
||||
(bitwise-and address #xff)))
|
||||
|
||||
(define (host-matches? info host)
|
||||
(cond
|
||||
((list? host)
|
||||
(let ((len (length host)))
|
||||
(any? (lambda (address)
|
||||
(equal? (take len (address->list address)) host))
|
||||
(host-info:addresses info))))
|
||||
(else ; (string? host)
|
||||
(any? (lambda (name)
|
||||
(string-match host (downcase-string name)))
|
||||
(cons (host-info:name info)
|
||||
(host-info:aliases info))))))
|
||||
|
||||
(define normalize-host
|
||||
(let ((split (infix-splitter "\\."))
|
||||
(number (make-regexp "[0-9]+")))
|
||||
(lambda (host)
|
||||
(let ((components (split host)))
|
||||
(if (every? (lambda (component)
|
||||
(regexp-exec number component))
|
||||
components)
|
||||
(map string->number components)
|
||||
host)))))
|
||||
|
||||
(define (take n l)
|
||||
(let loop ((n n) (l l) (r '()))
|
||||
(if (zero? n)
|
||||
(reverse r)
|
||||
(loop (- n 1) (cdr l) (cons (car l) r)))))
|
|
@ -0,0 +1,480 @@
|
|||
;;; http server in the Scheme Shell -*- Scheme -*-
|
||||
;;; Olin Shivers <shivers@lcs.mit.edu>
|
||||
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
|
||||
|
||||
;;; Problems:
|
||||
;;; Need to html-quote URI's when printing them out to HTML text.
|
||||
|
||||
;;; This file implements the core of an HTTP server: code to establish
|
||||
;;; net connections, read and parse requests, and handler errors.
|
||||
;;; It does not have the code to actually handle requests. That's up
|
||||
;;; to other modules, and could vary from server to server. To build
|
||||
;;; a complete server, you need to define path handlers (see below) --
|
||||
;;; they determine how requests are to be handled.
|
||||
;;;
|
||||
;;; A draft document detailing the HTTP 1.0 protocol can be found at
|
||||
;;; http://www.w3.org/hypertext/WWW/Protocols/HTTP1.0/
|
||||
;;; draft-ietf-http-spec.html
|
||||
|
||||
;;; Imports and non-R4RS'isms
|
||||
;;; \r \n in strings for cr and lf.
|
||||
;;; let-optionals (let-opt)
|
||||
;;; receive values (MV return)
|
||||
;;; scsh system calls
|
||||
;;; rfc822 header parsing
|
||||
;;; crlf-io (read cr/lf terminated lines)
|
||||
;;; when, unless, switch, ? (conditionals)
|
||||
;;; uri, url packages
|
||||
;;; defrec package (record structures)
|
||||
;;; defenum (enumerated types)
|
||||
;;; ignore-errors (HANDLE package)
|
||||
;;; string hacking stuff
|
||||
;;; char-set stuff
|
||||
;;; format (Formatted output)
|
||||
;;; httpd error stuff
|
||||
;;; condition-stuff (S48 error conditions)
|
||||
|
||||
;;; Constants
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define server/version "Scheme-Underground/1.0")
|
||||
(define server/protocol "HTTP/1.0")
|
||||
|
||||
;;; Configurable Variables
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Address for config error reports
|
||||
(define server/admin "sperber@informatik.uni-tuebingen.de")
|
||||
(define (set-server/admin! s)
|
||||
(set! server/admin s))
|
||||
|
||||
|
||||
(define *http-log?* #t)
|
||||
(define *http-log-port* (error-output-port))
|
||||
(define (http-log fmt . args)
|
||||
(? (*http-log?*
|
||||
(apply format *http-log-port* fmt args)
|
||||
(force-output *http-log-port*))))
|
||||
|
||||
|
||||
;;; (httpd path-handler [port server-root-dir])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; The server top-level. PATH-HANDLER is the top-level request path handler --
|
||||
;;; the procedure that actually deals with the request. PORT defaults to 80.
|
||||
;;; SERVER-ROOT-DIR is the server's working directory; it defaults to
|
||||
;;; /usr/local/etc/httpd
|
||||
|
||||
(define (httpd path-handler . args)
|
||||
(let-optionals args ((port 80)
|
||||
(root-dir "/usr/local/etc/httpd"))
|
||||
(with-cwd root-dir
|
||||
(bind-listen-accept-loop protocol-family/internet
|
||||
|
||||
;; Why is the output socket unbuffered? So that if the client
|
||||
;; closes the connection, we won't lose when we try to close the
|
||||
;; socket by trying to flush the output buffer.
|
||||
(lambda (sock addr) ; Called once for every connection.
|
||||
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
|
||||
|
||||
(fork (lambda () ; Kill this line to bag forking.
|
||||
(let* ((i (dup->inport (socket:inport sock) 0))
|
||||
(o (dup->outport (socket:outport sock) 1)))
|
||||
(set-port-buffering i bufpol/none) ; Should propagate. ecch.
|
||||
(with-current-input-port i ; bind the
|
||||
(with-current-output-port o ; stdio ports, &
|
||||
(process-toplevel-request path-handler sock))) ; do it.
|
||||
(close-input-port i) ; Really only necessary
|
||||
(close-output-port o)))) ; for non-forking variant.
|
||||
|
||||
(reap-zombies) ; Clean up: reap dead children,
|
||||
(close-socket sock)) ; and close socket.
|
||||
|
||||
port))))
|
||||
|
||||
;;; Top-level http request processor
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Read, parse, and handle a single http request. The only thing that makes
|
||||
;;; this complicated is handling errors -- as a server, we can't just let the
|
||||
;;; standard error handlers toss us into a breakpoint. We have to catch the
|
||||
;;; error, send an error reply back to the client if we can, and then keep
|
||||
;;; on trucking. This means using the S48's condition system to catch and
|
||||
;;; handle the various errors, which introduces a major point of R4RS
|
||||
;;; incompatibiliy -- R4RS has no exception system. So if you were to port
|
||||
;;; this code to some other Scheme, you'd really have to sit down and think
|
||||
;;; about this issue for a minute.
|
||||
|
||||
(define (process-toplevel-request handler sock)
|
||||
;; This top-level error-handler catches *all* uncaught errors and warnings.
|
||||
;; If the error condition is a reportable HTTP error, we send a reply back
|
||||
;; to the client. In any event, we abort the transaction, and return from
|
||||
;; PROCESS-TOPLEVEL-REQUEST.
|
||||
;;
|
||||
;; We *oughta* map non-http-errors into replies anyway.
|
||||
(with-fatal-error-handler (lambda (c decline) ; No call to decline
|
||||
(http-log "Error! ~s~%" c)
|
||||
(if (http-error? c) ; -- we handle all.
|
||||
(apply send-http-error-reply
|
||||
(condition-stuff c))))
|
||||
|
||||
(let ((req (with-fatal-error-handler ; Map syntax errors
|
||||
(lambda (c decline) ; to http errors.
|
||||
(if (fatal-syntax-error? c)
|
||||
(apply http-error http-reply/bad-request
|
||||
#f ; No request yet.
|
||||
"Request parsing error -- report to client maintainer."
|
||||
(condition-stuff c))
|
||||
(decline))) ; Actual work:
|
||||
(parse-http-request sock)))) ; (1) Parse request.
|
||||
(handler (http-url:path (request:url req)) req)))) ; (2) Deal with it.
|
||||
|
||||
|
||||
;;;; HTTP request parsing
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;; This code defines the http REQUEST data structure, and provides
|
||||
;;;; code to read requests from an input port.
|
||||
|
||||
(define-record request
|
||||
method ; A string such as "GET", "PUT", etc.
|
||||
uri ; The escaped URI string as read from request line.
|
||||
url ; An http URL record (see url.scm).
|
||||
version ; A (major . minor) integer pair.
|
||||
headers ; An rfc822 header alist (see rfc822.scm).
|
||||
socket) ; The socket connected to the client.
|
||||
|
||||
;;; A http protocol version is an integer pair: (major . minor).
|
||||
|
||||
(define (version< v1 v2)
|
||||
(or (< (car v1) (car v2))
|
||||
(and (= (car v1) (car v2))
|
||||
(< (cdr v1) (cdr v2)))))
|
||||
|
||||
(define (version<= v1 v2) (not (version< v2 v1)))
|
||||
|
||||
(define (v0.9-request? req)
|
||||
(version<= (request:version req) '(0 . 9)))
|
||||
|
||||
|
||||
(define (version->string v)
|
||||
(string-append "HTTP/"
|
||||
(number->string (car v))
|
||||
"."
|
||||
(number->string (cdr v))))
|
||||
|
||||
|
||||
;;; Read and parse an http request from INPORT.
|
||||
;;;
|
||||
;;; Note: this parser parses the URI into an http URL record. If the URI
|
||||
;;; isn't an http URL, the parser fails. This may not be right. There's
|
||||
;;; nothing in the http protocol to prevent you from passing a non-http
|
||||
;;; URI -- what this would mean, however, is not clear. Like so much of
|
||||
;;; the Web, the protocols are redundant, underconstrained, and ill-specified.
|
||||
|
||||
(define (parse-http-request sock)
|
||||
(let ((line (read-crlf-line)))
|
||||
|
||||
;; Blat out some logging info.
|
||||
|
||||
(if *http-log?*
|
||||
(let* ((addr (socket-remote-address sock))
|
||||
(host (host-info:name (host-info addr))))
|
||||
(http-log "~a: ~a~%" host line)))
|
||||
|
||||
(if (eof-object? line)
|
||||
(fatal-syntax-error "EOF while parsing request.")
|
||||
|
||||
(let* ((elts (string->words line)) ; Split at white-space.
|
||||
(version (switch = (length elts)
|
||||
((2) '(0 . 9))
|
||||
((3) (parse-http-version (caddr elts)))
|
||||
(else (fatal-syntax-error "Bad HTTP version.")))))
|
||||
|
||||
(let* ((meth (car elts))
|
||||
(uri-string (cadr elts))
|
||||
(url (parse-http-servers-url-fragment uri-string sock))
|
||||
(headers (if (equal? version '(0 . 9)) '()
|
||||
(read-rfc822-headers))))
|
||||
(make-request meth uri-string url version headers sock))))))
|
||||
|
||||
|
||||
|
||||
;;; Parse the URL, but if it begins without the "http://host:port" prefix,
|
||||
;;; interpolate one from SOCKET. It would sleazier but faster if we just
|
||||
;;; computed the default host and port at server-startup time, instead of
|
||||
;;; on every request.
|
||||
|
||||
(define (parse-http-servers-url-fragment uri-string socket)
|
||||
(receive (scheme path search frag-id) (parse-uri uri-string)
|
||||
(if frag-id ; Can't have a #frag part.
|
||||
(fatal-syntax-error "HTTP URL contains illegal #<fragment> suffix."
|
||||
uri-string)
|
||||
|
||||
(if scheme
|
||||
(if (string-ci=? scheme "http") ; Better be an http url.
|
||||
(parse-http-url path search #f)
|
||||
(fatal-syntax-error "Non-HTTP URL" uri-string))
|
||||
|
||||
;; Interpolate the userhost struct from our net connection.
|
||||
(if (and (pair? path) (string=? (car path) ""))
|
||||
(let* ((addr (socket-local-address socket))
|
||||
(local-name (my-fqdn addr))
|
||||
(portnum (my-port addr)))
|
||||
(make-http-url (make-userhost #f #f
|
||||
local-name
|
||||
(number->string portnum))
|
||||
(map unescape-uri (cdr path)) ;Skip initial /.
|
||||
search
|
||||
#f))
|
||||
|
||||
(fatal-syntax-error "Path fragment must begin with slash"
|
||||
uri-string))))))
|
||||
|
||||
|
||||
(define parse-http-version
|
||||
(let ((re (make-regexp "^HTTP/([0-9]+)\\.([0-9]+)$"))
|
||||
(lose (lambda (s) (fatal-syntax-error "Bad HTTP version" s))))
|
||||
(lambda (vstring)
|
||||
(let ((m (regexp-exec re vstring)))
|
||||
(if m
|
||||
(cons (or (string->number (match:substring m 1) 10) (lose vstring))
|
||||
(or (string->number (match:substring m 2) 10) (lose vstring)))
|
||||
(lose vstring))))))
|
||||
|
||||
|
||||
;;; Split string into a list of whitespace-separated strings.
|
||||
;;; This could have been trivially defined in scsh as (field-splitter " \t\n")
|
||||
;;; but I hand-coded it because it's short, and I didn't want invoke the
|
||||
;;; regexp machinery for something so simple.
|
||||
|
||||
(define non-whitespace (char-set-invert char-set:whitespace))
|
||||
|
||||
(define (string->words s)
|
||||
(let recur ((start 0))
|
||||
(? ((char-set-index s non-whitespace start) =>
|
||||
(lambda (start)
|
||||
(? ((char-set-index s char-set:whitespace start) =>
|
||||
(lambda (end)
|
||||
(cons (substring s start end)
|
||||
(recur end))))
|
||||
(else (list (substring s start (string-length s)))))))
|
||||
(else '()))))
|
||||
|
||||
|
||||
;;;; Sending replies
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Reply codes
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; (define http-reply/ok 200), etc.
|
||||
;;; Also, build an alist HTTP-REPLY-TEXT-TABLE mapping integer reply codes
|
||||
;;; to their diagnostic text messages.
|
||||
|
||||
(define-syntax define-http-reply-codes
|
||||
(syntax-rules ()
|
||||
((define-http-reply-codes table set (name val msg) ...)
|
||||
(begin (define table '((val . msg) ...))
|
||||
(define-enum-constant set name val)
|
||||
...))))
|
||||
|
||||
(define-http-reply-codes http-reply-text-table http-reply
|
||||
(ok 200 "OK")
|
||||
(created 201 "Created")
|
||||
(accepted 202 "Accepted")
|
||||
(prov-info 203 "Provisional Information")
|
||||
(no-content 204 "No Content")
|
||||
|
||||
(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"))
|
||||
|
||||
(define (reply-code->text code)
|
||||
(cdr (assv code http-reply-text-table)))
|
||||
|
||||
|
||||
;;; Text generation utilities.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (time->http-date-string time)
|
||||
(format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
||||
|
||||
;;; Output the first chunk of a reply header.
|
||||
|
||||
(define (begin-http-header out reply-code)
|
||||
(format out "~A ~d ~A\r~%"
|
||||
server/protocol reply-code (reply-code->text reply-code))
|
||||
(format out "Date: ~A\r~%" (time->http-date-string (time)))
|
||||
(format out "Server: ~A\r~%" server/version))
|
||||
|
||||
(define (title-html out message new-protocol?)
|
||||
(if new-protocol? (write-crlf out)) ; Separate html from headers.
|
||||
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
|
||||
(format out "<BODY>~%<H1>~A</H1>~%" message))
|
||||
|
||||
|
||||
;;; (send-http-error-reply reply-code req [message . extras])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Take an http-error condition, and format it into a reply to the client.
|
||||
;;;
|
||||
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
|
||||
;;; even had a chance to parse and construct the request. This is only used
|
||||
;;; for 400 BAD-REQUEST error report, and we make minimal assumptions in this
|
||||
;;; case (0.9 protocol for the reply, for example). I might be better off
|
||||
;;; writing a special-case procedure for that case...
|
||||
|
||||
;;; SEND-HTTP-ERROR-REPLY is called from error handlers, so to avoid
|
||||
;;; infinite looping, if an error occurs while it is running, we just
|
||||
;;; silently return. (We no longer need to do this; I have changed
|
||||
;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll
|
||||
;;; leave it in to play it safe.)
|
||||
|
||||
(define (send-http-error-reply reply-code req . args)
|
||||
(ignore-errors (lambda () ; Ignore errors -- see note above.
|
||||
(apply really-send-http-error-reply reply-code req args))))
|
||||
|
||||
(define (really-send-http-error-reply reply-code req . args)
|
||||
(let* ((message (if (pair? args) (car args)))
|
||||
(extras (if (pair? args) (cdr args) '()))
|
||||
|
||||
(new-protocol? (and req (not (v0.9-request? req)))) ; 1.0 or better?
|
||||
|
||||
;; Is it OK to send back an HTML body explaining things?
|
||||
(html-ok? (or (not req)
|
||||
(not (string=? (request:method req) "HEAD"))))
|
||||
|
||||
(out (current-output-port))
|
||||
|
||||
(generic-title (lambda ()
|
||||
(title-html out
|
||||
(reply-code->text reply-code)
|
||||
new-protocol?)))
|
||||
|
||||
(do-msg (lambda () (? (message (display message out) (newline out))))))
|
||||
|
||||
(if new-protocol? (begin-http-header out reply-code))
|
||||
|
||||
;; Don't output the blank line, as individual clauses might
|
||||
;; want to add more headers.
|
||||
(if html-ok? (write-string "Content-type: text/html\r\n" out))
|
||||
|
||||
;; If html-ok?, we must send back some html, with the <body> tag unclosed.
|
||||
(switch = reply-code
|
||||
|
||||
;; This error reply requires two args: message is the new URI: field,
|
||||
;; and the first EXTRA is the older Location: field.
|
||||
((http-reply/moved-temp http-reply/moved-perm)
|
||||
(when new-protocol?
|
||||
(format out "URI: ~A\r~%" message)
|
||||
(format out "Location: ~A\r~%" (car extras)))
|
||||
(when html-ok?
|
||||
(title-html out "Document moved" new-protocol?)
|
||||
(format out
|
||||
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
|
||||
(if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
|
||||
message)))
|
||||
|
||||
((http-reply/bad-request)
|
||||
(when html-ok?
|
||||
(generic-title)
|
||||
(write-string "<P>Client sent a query that this server could not understand.\n"
|
||||
out)
|
||||
(if message (format out "<BR>~%Reason: ~A~%" message))))
|
||||
|
||||
((http-reply/unauthorized)
|
||||
(if new-protocol?
|
||||
(format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
|
||||
(when html-ok?
|
||||
(title-html out "Authorization Required" new-protocol?)
|
||||
(write-string "<P>Browser not authentication-capable or\n" out)
|
||||
(write-string "authentication failed.\n" out)
|
||||
(if message (format out "~a~%" message))))
|
||||
|
||||
((http-reply/forbidden)
|
||||
(unless html-ok?
|
||||
(title-html out "Request not allowed." new-protocol?)
|
||||
(format out "Your client does not have permission to perform a ~A~%"
|
||||
(request:method req))
|
||||
(format out "operation on url ~a.~%" (request:uri req))
|
||||
(if message (format out "<P>~%~a~%" message))))
|
||||
|
||||
((http-reply/not-found)
|
||||
(when html-ok?
|
||||
(title-html out "URL not found" new-protocol?)
|
||||
(write-string "<P>The requested URL was not found on this server.\n"
|
||||
out)
|
||||
(if message (format out "<P>~%~a~%" message))))
|
||||
|
||||
((http-reply/internal-error)
|
||||
(format (error-output-port) "ERROR: ~A~%" message)
|
||||
(when html-ok?
|
||||
(generic-title)
|
||||
(format out "The server encountered an internal error or
|
||||
misconfiguration and was unable to complete your request.
|
||||
<P>
|
||||
Please inform the server administrator, ~A, of the circumstances leading to
|
||||
the error, and time it occured.~%"
|
||||
server/admin)
|
||||
(if message (format out "<P>~%~a~%" message))))
|
||||
|
||||
((http-reply/not-implemented)
|
||||
(when html-ok?
|
||||
(generic-title)
|
||||
(format out "This server does not currently implement
|
||||
the requested method (~A).~%"
|
||||
(request:method req))
|
||||
(if message (format out "<P>~a~%" message))))
|
||||
|
||||
(else (if html-ok? (generic-title))))
|
||||
|
||||
(? (html-ok?
|
||||
;; Output extra stuff and close the <body> tag.
|
||||
(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
|
||||
(write-string "</BODY>\n" out)))
|
||||
(force-output out)
|
||||
; (if bkp? (breakpoint "http error"))
|
||||
))
|
||||
|
||||
|
||||
;;; Return my Internet host name (my fully-qualified domain name).
|
||||
;;; This works only if an actual resolver is behind host-info.
|
||||
;;;
|
||||
;;; On systems that do DNS via NIS/Yellow Pages, you only get an
|
||||
;;; unqualified hostname. Also, in case of aliased names, you just
|
||||
;;; might get the wrong one. Furthermore, you may get screwed in the
|
||||
;;; presence of a server accelerator such as Squid.
|
||||
;;;
|
||||
;;; In these cases, and on NeXTSTEP, you'll have to set it by hand.
|
||||
|
||||
(define (my-fqdn addr)
|
||||
(or *my-fqdn*
|
||||
(host-info:name (host-info addr))))
|
||||
|
||||
(define *my-fqdn* #f)
|
||||
(define (set-my-fqdn! fqdn)
|
||||
(set! *my-fqdn* fqdn))
|
||||
|
||||
(define (my-port addr)
|
||||
(or *my-port*
|
||||
(receive (ip-addr portnum) (socket-address->internet-address addr)
|
||||
portnum)))
|
||||
(define *my-port* #f)
|
||||
(define (set-my-port! portnum)
|
||||
(set! *my-port* portnum))
|
|
@ -0,0 +1,131 @@
|
|||
;;; Error stuff for the http server. -*- Scheme -*-
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
|
||||
;;; An http error condition is a data structure with the following pieces:
|
||||
;;; (error-code request message . irritants)
|
||||
;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
|
||||
;;; CONDITION-STUFF.
|
||||
;;;
|
||||
;;; You can find out more about the Scheme 48 condition system by consulting
|
||||
;;; s48-error.txt, where I scribbled some notes as I was browsing the source
|
||||
;;; code when I wrote this file.
|
||||
|
||||
;;; ,open conditions signals handle
|
||||
|
||||
;;; HTTP error condition
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Define a sub-type of the S48 error condition, the HTTP error condition.
|
||||
;;; An HTTP error is one that corresponds to one of the HTTP error reply
|
||||
;;; codes, so you can reliably use an HTTP error condition to construct an
|
||||
;;; error reply message to send back to the HTTP client.
|
||||
|
||||
(define-condition-type 'http-error '(error))
|
||||
|
||||
(define http-error? (condition-predicate 'http-error))
|
||||
|
||||
(define (http-error error-code req . args)
|
||||
(apply signal 'http-error error-code req args))
|
||||
|
||||
;;; Syntax error condition
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
|
||||
;;; condition! It's a warning condition. I don't understand this.
|
||||
;;; We define a *fatal* syntax error here for the parsers to use.
|
||||
|
||||
(define-condition-type 'fatal-syntax-error '(error))
|
||||
|
||||
(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
|
||||
|
||||
(define (fatal-syntax-error msg . irritants)
|
||||
(apply signal 'fatal-syntax-error msg irritants))
|
||||
|
||||
|
||||
;;; (with-fatal-error-handler* handler thunk)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
|
||||
;;; and that condition is an error condition (or a subtype of error), then
|
||||
;;; HANDLER gets a chance to handle it.
|
||||
;;; The HANDLER proc is applied to two values:
|
||||
;;; (HANDLER condition decline)
|
||||
;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
|
||||
;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
|
||||
;;; handle the error by throwing to DECLINE, a nullary continuation.
|
||||
;;;
|
||||
;;; Why is it called with-FATAL-error-handler*? Because returning to the
|
||||
;;; guy that signalled the error is not an option.
|
||||
;;;
|
||||
;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
|
||||
;;; error handler *itself* raises an error? This could potentially give
|
||||
;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
|
||||
;;; the original condition-signaller's context, so you'd search back for a
|
||||
;;; handler, and find yourself again. For example, here is an infinite loop:
|
||||
;;;
|
||||
;;; (with-handler (lambda (condition more)
|
||||
;;; (display "Loop!")
|
||||
;;; (error "ouch")) ; Get back, Loretta.
|
||||
;;; (lambda () (error "start me up")))
|
||||
;;;
|
||||
;;; I could require W-F-E-H* users to code carefully, but instead I make sure
|
||||
;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
|
||||
;;; if it signals a condition, we'll start the search from there. That's the
|
||||
;;; point of continuation K. When the original thunk completes successfully,
|
||||
;;; we dodge the K hackery by using ACCEPT to make a normal return.
|
||||
|
||||
(define (with-fatal-error-handler* handler thunk)
|
||||
(call-with-current-continuation
|
||||
(lambda (accept)
|
||||
((call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-handler (lambda (condition more)
|
||||
(if (error? condition)
|
||||
(call-with-current-continuation
|
||||
(lambda (decline)
|
||||
(k (lambda () (handler condition decline))))))
|
||||
(more)) ; Keep looking for a handler.
|
||||
(lambda () (call-with-values thunk accept)))))))))
|
||||
|
||||
(define-syntax with-fatal-error-handler
|
||||
(syntax-rules ()
|
||||
((with-fatal-error-handler handler body ...)
|
||||
(with-fatal-error-handler* handler
|
||||
(lambda () body ...)))))
|
||||
|
||||
;This one ran HANDLER in the signaller's condition-handler context.
|
||||
;It was therefore susceptible to infinite loops if you didn't code
|
||||
;your handler's carefully.
|
||||
;
|
||||
;(define (with-fatal-error-handler* handler thunk)
|
||||
; (call-with-current-continuation
|
||||
; (lambda (accept)
|
||||
; (with-handler (lambda (condition more)
|
||||
; (if (error? condition)
|
||||
; (call-with-current-continuation
|
||||
; (lambda (decline)
|
||||
; (accept (handler condition decline)))))
|
||||
; (more)) ; Keep looking for a handler.
|
||||
; thunk))))
|
||||
|
||||
;;; (%error-handler-cond kont eh-clauses cond-clauses)
|
||||
;;; Transform error-handler clauses into COND clauses by wrapping continuation
|
||||
;;; KONT around the body of each e-h clause, so that if it fires, the result
|
||||
;;; is thrown to KONT, but if no clause fires, the cond returns to the default
|
||||
;;; continuation.
|
||||
|
||||
;(define-syntax %error-handler-cond
|
||||
; (syntax-rules (=> else)
|
||||
;
|
||||
; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
|
||||
; (%error-handler-cond kont
|
||||
; (clause ...)
|
||||
; ((test => (lambda (v) (kont (proc v)))) ans ...)))
|
||||
;
|
||||