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

*** empty log message ***

This commit is contained in:
mainzelm 2000-09-26 14:35:26 +00:00
commit 01310403c1
28 changed files with 5170 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
.gitignore vendored Normal file
View File

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

26
COPYING Normal file
View File

@ -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.

27
ChangeLog Normal file
View File

@ -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.

45
Readme Normal file
View 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

94
cgi-script.scm Normal file
View File

@ -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.

279
cgi-server.scm Normal file
View File

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

98
conditionals.scm Normal file
View File

@ -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.

39
crlf-io.scm Normal file
View File

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

196
htmlout.scm Normal file
View File

@ -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) "&lt;")
(cons (ascii->char 62) "&gt;")
(cons (ascii->char 38) "&amp;")
(cons (ascii->char 34) "&quot;")))
(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))))

58
http-top.scm Normal file
View File

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

77
httpd-access-control.scm Normal file
View File

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

480
httpd-core.scm Normal file
View File

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

131
httpd-error.scm Normal file
View File

@ -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 ...)))
;