rename READ-AND-DISCARD-TRAILER to DISCARD-TRAILER for naming consistency

implementation of chunked transfer coding in handler-lib

COPYING

@@ -1,7 +1,10 @@
 Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
+Copyright (c) 1995-1996 by Olin Shivers.
 Copyright (c) 1996-2001 by Mike Sperber.
 Copyright (c) 1999-2001 by Martin Gasbichler.
 Copyright (c) 1998-2001 by Eric Marsden.
+Copyright (c) 2001-2003 by Andreas Bernauer.
+Copyright (c) 2004-2005 by Viola Brunner.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

README

@@ -9,15 +9,15 @@ Scsh's facilities for multi-threaded systems programming und Unix.
 SUnet includes the following components:
 
 * The SUnet Web server
-    This is a highly configurable HTTP 1.0 server in Scheme.
+    This is a highly configurable HTTP 1.1 server in Scheme.
-    The server is accompanied some libraries which may also
+    The server is accompanied by some libraries which may also
     be used separately:
 
-    * URI and URL parsers and unparsers
+    * an URL parser and unparser
     * a library for writing CGI scripts in Scheme
     * server extensions for interfacing to CGI scripts
     * server extensions for uploading Scheme code
-    * simple structured HTML output library
+    * a simple structured HTML output library
 
     The server also ships with a sophisticated interface for writing
     server-side Web applications called "SUrflets".
@@ -110,8 +110,7 @@ scsh@zurich.ai.mit.edu
 
 Relax, hack, and enjoy!
 
-Dr. S.
+Michael Sperber
-Dr. S.
 Martin Gasbichler
 Eric Marsden
 Andreas Bernauer

doc/latex/httpd.tex

@@ -204,34 +204,41 @@ constructing responses lives in the \ex{httpd-responses} structure.
   \var{Location} must be URI-encoded and begin with a slash.
 \end{desc}
 
-\defun{make-error-response}{status-code request [message] extras \ldots}{response}
+\defun{make-error-response}{status-code request extra \ldots}{response}
 \begin{desc}
   This is a helper procedure for constructing error responses.
-  \var{code} is status code of the response (see below). \var{Request}
+  \ex{Make-error-response} returns a response value the body of which
-  is the request that led to the error.  \var{Message} is an optional
+  is a web page explaining the error at hand.
-  string containing an error message written in HTML, and \var{extras}
+  \var{status-code} is the status code of the response (see below).
-  are further optional arguments containing further message lines to
+  \var{request}
+  is the request that led to the error.  \var{extra} are the further
+  arguments required for this specific \var{status-code} and
+  optionally further information-bits (preferably strings in HTML) to
   be added to the web page that's generated.
-
-  \ex{Make-error-response} constructs a response value which generates
-  a web page containg a short explanatory message for the error at hand.
 \end{desc}
 
 \begin{table}[htb]
   \centering
   \begin{tabular}{|l|l|l|}
     \hline
+   continue &	 	100 & Continue\\\hline
+   switch-protocol &	101 & Switching Protocol\\\hline
+
    ok &                 200 & OK\\\hline
    created &            201 & Created\\\hline
    accepted &           202 & Accepted\\\hline
-   prov-info &          203 & Provisional Information\\\hline
+   non-author-info &    203 & Non-Authoritative Information\\\hline
    no-content &         204 & No Content\\\hline
+   reset-content &	205 & Reset Content\\\hline
+   partial-content &	206 & Partial Content\\\hline
 
    mult-choice &        300 & Multiple Choices\\\hline
    moved-perm &         301 & Moved Permanently\\\hline
-   moved-temp &         302 & Moved Temporarily\\\hline
+   found &         	302 & Found\\\hline
-   method &             303 & Method (obsolete)\\\hline
+   see-other &          303 & See other\\\hline
    not-mod &            304 & Not Modified\\\hline
+   use-proxy &		305 & Use Proxy\\\hline
+   temp-redirect &	307 & Temporary Redirect\\\hline
 
    bad-request &        400 & Bad Request\\\hline
    unauthorized &       401 & Unauthorized\\\hline
@@ -239,16 +246,26 @@ constructing responses lives in the \ex{httpd-responses} structure.
    forbidden &          403 & Forbidden\\\hline
    not-found &          404 & Not Found\\\hline
    method-not-allowed & 405 & Method Not Allowed\\\hline
-   none-acceptable &    406 & None Acceptable\\\hline
+   not-acceptable &    	406 & Not Acceptable\\\hline
-   proxy-auth-required & 407 & Proxy Authentication Required\\\hline
+   proxy-auth-required &407 & Proxy Authentication Required\\\hline
    timeout &            408 & Request Timeout\\\hline
    conflict &           409 & Conflict\\\hline
    gone &               410 & Gone\\\hline
+   length-required &	411 & Length Required\\\hline
+   precon-failed &	412 & Precondition Failed\\\hline
+   req-ent-too-large &	413 & Request Entity Too Large\\\hline
+   req-uri-too-large &	414 & Request URI Too Large\\\hline
+   unsupp-media-type &	415 & Unsupported Media Type\\\hline
+   req-range-not-sat &	416 & Requested Range Not Satisfiable\\\hline
+   expectation-failed &	417 & Expectation Failed\\\hline
+
    internal-error &     500 & Internal Server Error\\\hline
    not-implemented &    501 & Not Implemented\\\hline
    bad-gateway &        502 & Bad Gateway\\\hline
-   service-unavailable & 503 & Service Unavailable\\\hline
+   service-unavailable &503 & Service Unavailable\\\hline
    gateway-timeout &    504 & Gateway Timeout\\\hline
+   version-not-supp &	505 & HTTP Version Not Supported\\\hline
+
   \end{tabular}
   \caption{HTTP status codes}
   \label{tab:status-code-names}
@@ -334,8 +351,8 @@ exported by the \ex{httpd\=basic\=handlers} structure:
 
 \defvar{null-request-handler}{request-handler}
 \begin{desc}
-  This request handler always generated a \ex{not-found} error
+  This request handler always generates a \ex{not-found} error
-  response, no patter what the request is.
+  response, no matter what the request is.
 \end{desc}
 
 \defun{make-predicate-handler}{predicate handler

doc/latex/uri.tex

@@ -1,164 +1,48 @@
-\chapter{Parsing and Processing URIs}\label{cha:uri}
+\chapter{Processing URIs}\label{cha:uri}
 
-The \ex{uri} structure contains a library for dealing with URIs.
+The \ex{uri} module contains library functions for dealing with URIs.
 
 \section{Notes on URI Syntax}
 
-A URI (Uniform Resource Identifier) is of following syntax:
+The generic syntax of URI (Uniform Resource Identifier) is defined in
-%
+RFC 2396; see Appendix A for a collected BNF of URI.
-\begin{inset}
-[\var{scheme}] \verb|:| \var{path} [\verb|?| \var{search}] [\verb|#| \var{fragid}]
-\end{inset}
-%
-Parts in brackets may be omitted.
 
-The URI contains characters like \verb|:| to indicate its different
+Within URI non-printable Ascii characters are represented by an
-parts.  Some special characters are \emph{escaped} if they are a
+\emph{escape encoding}. \emph{Reserved} characters used as
-regular part of a name and not indicators for the structure of a URI.
+delimiters indicating the different parts of a URI also must be
-Escape sequences are of following scheme: \verb|%|\var{h}\var{h} where \var{h}
+\emph{escaped} if they are to be regular data of a URI component. The
-is a hexadecimal digit.  The hexadecimal number refers to the
+set of characters actually \emph{reserved} within any given URI
-ASCII of the escaped character, e.g.\ \verb|%20| is space (ASCII
+component is defined by that component. Therefore
-32) and \verb|%61| is `a' (ASCII 97). This module
+\emph{escaping} can only be done when the URI is being created from
-provides procedures to escape and unescape strings that are meant to
+its component parts; likewise, a URI must be separated into its
-be used in a URI.
+component parts before \emph{unescaping} can be done.
+
+Escape sequences are of the following scheme: \verb|%| \var{h}\var{h}
+where \var{h}\var{h} are the two hexadecimal digits representing the octet code. For
+example \verb|%20| is the escaped encoding for the US-ASCII space character.
 
 \section{Procedures}
 
-\defun{parse-uri} {uri-string } {scheme path search
+\defun{unescape}{string}{string}
-    frag-id} \label{proc:parse-uri}
 \begin{desc}
-  Parses an \var{uri\=string} into its four fields.
+  \ex{Unescape} unescapes a string. 
-  The fields are \emph{not} unescaped, as the rules for
-  parsing the \var{path} component in particular need unescaped
-  text, and are dependent on \var{scheme}. The URL parser is
-  responsible for doing this.  If the \var{scheme}, \var{search}
-  or \var{fragid} portions are not specified, they are \sharpf.
-  Otherwise, \var{scheme}, \var{search}, and \var{fragid} are
-  strings. \var{path} is a non-empty string list---the path split
-  at slashes.
-\end{desc}
-
-Here is a description of the parsing technique. It is inwards from
-both ends:
-\begin{itemize}
-\item First, the code searches forwards for the first reserved
-  character (\verb|=|, \verb|;|, \verb|/|, \verb|#|, \verb|?|,
-  \verb|:| or \verb|space|).  If it's a colon, then that's the
-  \var{scheme} part, otherwise there is no \var{scheme} part. At
-  all events, it is removed.
-\item Then the code searches backwards from the end for the last reserved
-  char.  If it's a sharp, then that's the \var{fragid} part---remove it.
-\item Then the code searches backwards from the end for the last reserved
-  char.  If it's a question-mark, then that's the \var{search}
-  part----remove it.
-\item What's left is the path.  The code split it at slashes. The
-  empty string becomes a list containing the empty string.
-\end{itemize}
-%  
-This scheme is tolerant of the various ways people build broken
-URI's out there on the Net\footnote{So it does not absolutely conform
-  to RFC~1630.}, e.g.\ \verb|=| is a reserved character, but used
-unescaped in the search-part. It was given to me\footnote{That's
-  Olin Shivers.} by Dan Connolly of the W3C and slightly modified.
-
-\defun{unescape-uri}{string [start] [end]}{string}
-\begin{desc}
-  \ex{Unescape-uri} unescapes a string. If \var{start} and/or \var{end} are
-  specified, they specify start and end positions within \var{string}
-  should be unescaped.
 \end{desc}
 %
-This procedure should only be used \emph{after} the URI was parsed,
+This procedure may only be used \emph{after} the URI was parsed into
-since unescaping may introduce characters that blow up the
+its component parts (see above).
-parse---that's why escape sequences are used in URIs.
 
-\defvar{uri-escaped-chars}{char-set}
+\defun{escape} {string regexp} {string}
 \begin{desc}
-  This is a set of characters (in the sense of SRFI~14) which are
+  \ex{Escape} replaces reserved or excluded characters in \var{string}
-  escaped in URIs.  RFC 2396 defines this set as all characters which 
+  by their escaped representation. \var{regexp} defines which
-  are neither letters, nor digits, nor one of the following characters:
+  characters are reserved or excluded within the particular URI component
-   \verb|-|, \verb|_|, \verb|.|, \verb|!|, %$
+  being escaped.
-   \verb|~|, \verb|*|, \verb|'|, \verb|(|, \verb|)|.
 \end{desc}
 
-\defun{escape-uri} {string [escaped-chars]} {string}
+This procedure may only be used on a URI \emph{component part}, not on a
-\begin{desc}
+complete URI made up of several component parts (see above). Use it to
-  This procedure escapes characters of \var{string} that are in
+write specialized escape-procedures for the respective component
-  \var{escaped\=chars}. \var{Escaped\=chars} defaults to
+parts. (See the \ex{url} module for examples).
-  \ex{uri\=escaped\=chars}.  
-\end{desc}
-%
-Be careful with using this procedure to chunks of text with
-syntactically meaningful reserved characters (e.g., paths with URI
-slashes or colons)---they'll be escaped, and lose their special
-meaning. E.g.\ it would be a mistake to apply \ex{escape-uri} to
-\begin{verbatim}
-//lcs.mit.edu:8001/foo/bar.html
-\end{verbatim}
-%
-because the sla\-shes and co\-lons would be escaped.
-
-\defun{split-uri}{uri start end} {list}
-\begin{desc}
-  This procedure splits \var{uri} at slashes. Only the substring given
-  with \var{start} (inclusive) and \var{end} (exclusive) as indices is
-  considered.  \var{start} and $\var{end} - 1$ have to be within the
-  range of \var{uri}.  Otherwise an \ex{index-out-of-range} exception
-  will be raised.
-  
-  Example: \codex{(split-uri "foo/bar/colon" 4 11)} returns
-  \codex{("bar" "col")}
-\end{desc}
-
-\defun{uri-path->uri}{path}{string}
-\begin{desc}
-  This procedure generates a path out of a URI path list by inserting
-  slashes between the elements of \var{plist}.
-\end{desc}
-%
-If you want to use the resulting string for further operation, you
-should escape the elements of \var{plist} in case they contain
-slashes, like so:
-%
-\begin{verbatim}
-(uri-path->uri (map escape-uri pathlist))
-\end{verbatim}
-
-\defun{simplify-uri-path}{path}{list}
-\begin{desc}
-  This procedure simplifies a URI path.  It removes \verb|"."| and
-  \verb|"/.."| entries from path, and removes parts before a root.
-  The result is a list, or \sharpf{} if the path tries to back up past
-  root.
-\end{desc}
-%
-According to RFC~2396, relative paths are considered not to start with
-\verb|/|.  They are appended to a base URL path and then simplified.
-So before you start to simplify a URL try to find out if it is a
-relative path (i.e. it does not start with a \verb|/|).
-
-Examples:
-%
-\begin{alltt}
-(simplify-uri-path (split-uri  "/foo/bar/baz/.."  0 15))
-\(\Rightarrow\) ("" "foo" "bar")
-
-(simplify-uri-path (split-uri "foo/bar/baz/../../.." 0 20))
-\(\Rightarrow\) ()
-
-(simplify-uri-path (split-uri "/foo/../.." 0 10))
-\(\Rightarrow\) #f
-
-(simplify-uri-path (split-uri "foo/bar//" 0 9))
-\(\Rightarrow\) ("")     
-
-(simplify-uri-path (split-uri "foo/bar/" 0 8))
-\(\Rightarrow\) ("")
-
-(simplify-uri-path (split-uri "/foo/bar//baz/../.." 0 19))
-\(\Rightarrow\) #f
-\end{alltt}
-
 
 %%% Local Variables: 
 %%% mode: latex

doc/latex/url.tex

@@ -1,110 +1,74 @@
 \chapter{Parsing and Processing URLs}\label{cha:url}
 %
-This modules contains procedures to parse and unparse URLs.  Until
+The \ex{url} module contains procedures to parse and unparse HTTP 1.1 Request-URIs.
-now, only the parsing of HTTP URLs is implemented.
 
-\section{Server Records}
+\defun{url-string->http-url}{string}{http-url}
-
-A \textit{server} value describes path prefixes of the form
-\var{user}:\var{password}@\var{host}:\var{port}. These are
-frequently used as the initial prefix of URLs describing Internet
-resources.
-
-\defun{make-server}{user password host port}{server}
-\defunx{server?}{thing}{boolean}
-\defunx{server-user}{server}{string-or-\sharpf}
-\defunx{server-password}{server}{string-or-\sharpf}
-\defunx{server-host}{server}{string-or-\sharpf}
-\defunx{server-port}{server}{string-or-\sharpf}
 \begin{desc}
-  \ex{Make-server} creates a new server record.  Each slot is a
+ \ex{Url-string->http-url} parses the Request-URI \var{string} into a
-  decoded string or \sharpf. (\var{Port} is also a string.)
+ \ex{http-url} record.
-  
-  \ex{server?} is the corresponding predicate, \ex{server-user},
-  \ex{server-password}, \ex{server-host} and \ex{server-port}
-  are the correspondig selectors.
 \end{desc}
 
-\defun{parse-server}{path default}{server}
+\defun{http-url?}{thing}{boolean}
-\defunx{server->string}{server}{string}
 \begin{desc}
-  \ex{Parse-server} parses a URI path \var{path} (a list representing
+  \ex{http-url?} is the predicate for the \ex{http-url} record.
-  a path, not a string) into a server value.  Default values are taken
-  from the server \var{default} except for the host.  The values
-  are unescaped and stored into a server record that is returned.
-  \ex{Fatal-syntax-error} is called, if the specified path has no
-  initial to slashes (i.e., it starts with `//\ldots').
-  
-  \ex{server->string} just does the inverse job: it unparses
-  \var{server} into a string. The elements of the record
-  are escaped before they are put together.  
-
-  Example:
-\begin{alltt}
-> (define default (make-server "andreas"  "se ret" "www.sf.net" "80"))
-> (server->string default)
-"andreas:se\%20ret@www.sf.net:80"
-> (parse-server '("" "" "foo\%20bar@www.scsh.net" "docu" "index.html") 
-                default)
-'#{server}
-> (server->string ##)
-"foo\%20bar:se\%20ret@www.scsh.net:80"
-\end{alltt}
-%
-For details about escaping and unescaping see Chapter~\ref{cha:uri}.
 \end{desc}
 
-\section{HTTP URLs}
+\defun{http-url-host}{http-url}{string or \sharpf}
-
+\defunx{http-url-port}{http-url}{integer or \sharpf}
-\defun{make-http-url}{server path search frag-id}{http-url}
-\defunx{http-url?}{thing}{boolean}
-\defunx{http-url-server}{http-url}{server}
 \defunx{http-url-path}{http-url}{list}
-\defunx{http-url-search}{http-url}{string-or-\sharpf}
+\defunx{http-url-query}{http-url}{string or \sharpf}
-\defunx{http-url-frag-ment-identifier}{http-url}{string-or-\sharpf}
+
-%
 \begin{desc}
-  \ex{Make-http-url} creates a new \ex{httpd-url} record.
+  \ex{http-url-host}, \ex{http-url-port}, \ex{http-url-path} and
-  \var{Server} is a record, containing the initial part of the address
+  \ex{http-url-query} are the selectors for the \ex{http-url} record.
-  (like \ex{anonymous@clark.lcs.mit.edu:80}).  \var{Path} contains the
+
-  URL's URI path ( a list).  These elements are in raw, unescaped
+  The \var{host} slot is a non-empty string or \sharpf. 
-  format. To convert them back to a string, use
+
-  \ex{(uri-path->uri (map escape-uri pathlist))}. \var{Search}
+  The \var{port} slot is an integer or \sharpf.
-  and \var{frag-id} are the last two parts of the URL.  (See
+ 
-  Chapter~\ref{cha:uri} about parts of an URI.)
+  The \var{path} slot is a list of strings containing the
-  
+  Request-URI's path split at slashes and \emph{unescaped}.If the
-  \ex{Http-url?} is the predicate for HTTP URL values, and
+  Request-URI's path ends with a slash, an empty string is inserted as
-  \ex{http-url-server}, \ex{http-url-path}, \ex{http-url-search} and
+  the last element of the list.
-  \ex{http-url-fragment-identifier} are the corresponding selectors.
+
+  The \var{query} slot is an non-empty-string, still in its
+  \emph{escaped} representation, or \sharpf.
+\end{desc}
+%
+Examples for Request-URI strings and the slots of the corresponding
+http-url record: \nopagebreak
+\begin{alltt}
+"http://foo.bar.org:7777///foo%20foo//bar.htm?bulb%20bulb"
+\(\Rightarrow\) "foo.bar.org" 7777 '("foo foo" "bar.htm") "bulb%20bulb"
+
+"http://foo.bar.org"
+\(\Rightarrow\) "foo.bar.org" #f '() #f
+
+"http://foo.bar.org//"
+\(\Rightarrow\) "foo.bar.org" #f '("") #f
+
+"/foo%20foo//bar.htm?bulb%20bulb"
+\(\Rightarrow\)  #f #f '("foo foo" "bar.htm") "bulb%20bulb"
+
+"/foo%20foo//?bulb%20bulb"
+\(\Rightarrow\)  #f #f '("foo foo" "") "bulb%20bulb"
+
+"/" 
+\(\Rightarrow\) #f #f '("") #f
+\end{alltt}
+
+
+\defun{http-url->url-string}{http-url}{string}
+\begin{desc}
+  \ex{http-url->url-string} unparses a \ex{http-url} record and returns the
+  Request-URI \ex{string} of the original HTTP Request.
 \end{desc}
 
-\defun{parse-http-url}{path search frag-id}{http-url}
+\defun{http-url-path->path-string}{http-url-path}{string}
-\begin{defundescx}{http-url->string}{http-url}{string}
-  This constructs an HTTP URL record from a URI path (a list of path
-  components), a search, and a frag-id component.
-  
-  \ex{Http-url->string} just does the inverse job. It converts an
-  HTTP URL record into a string.
-\end{defundescx}
-%
-Note: The URI parser \ex{parse-uri} maps a string to four parts:
-\var{scheme}, \var{path}, \var{search} and \var{frag-id} (see
-Section~\ref{proc:parse-uri} for details). If \var{scheme} is
-\ex{http}, then the other three parts can be passed to
-\ex{parse-http-url}, which parses them into a \ex{http-url} record.
-All strings come back from the URI parser encoded.  \var{Search} and
-\var{frag-id} are left that way; this parser decodes the path
-elements.  The first two list elements of the path indicating the
-leading double-slash are omitted.
-
-The following procedure combines the jobs of \ex{parse-uri} and
-\ex{parse-http-url}:
-
-\defun{parse-http-url-string}{string}{http-url}
 \begin{desc}
-  This parses an HTTP URL and returns the corresponding URL value; it
+  \ex{http-url-path->url-string} unparses the \ex{http-url-path} field of
-  calls \ex{fatal-syntax-error} if the URL string doesn't have an
+  an http-url record into its corresponding part of the Request-URI
-  \ex{http} scheme.
+  \ex{string} of the original HTTP Request (re-escaping the path).
 \end{desc}
 
 %%% Local Variables: 

pkg-def.scm

@@ -5,6 +5,10 @@
   (let ((surflets? (get-option-value 'with-surflets)))
     (install-directory-contents "scheme" 'scheme)
     (install-directory "web-server" 'misc-shared)
+    (install-file "start-web-server" 'misc-shared "web-server")
+    (install-file "start-extended-web-server" 'misc-shared "web-server")
+    (if surflets?
+        (install-file "start-surflet-server" 'misc-shared "web-server"))
     (install-directory-contents "doc" 'doc)
 
     (let ((doc-dir (get-directory 'doc #t))

scheme/httpd/cgi-server.scm

@@ -103,7 +103,7 @@
 	 (nph? (string-prefix? "nph-" prog))	; PROG starts with "nph-" ? 
 					; why did we had (string-suffix? "-nph" prog) here?
 
-	 (search (http-url-search (request-url req)))	; Compute the
+	 (search (http-url-query (request-url req)))	; Compute the
 	 (argv (if (and search (not (string-index search #\=)))	; argv list.
 		   (split-and-decode-search-spec search)
 		   '()))
@@ -124,25 +124,29 @@
 	(case (file-not-executable? filename)
 	  ((search-denied permission)
 	   (make-error-response (status-code forbidden) req
-				"Permission denied."))
+				"No permission to search directory."))
 	  ((no-directory nonexistent)
-	   (make-error-response (status-code not-found) req
+	   (make-error-response (status-code not-found) req))
-				"File or directory doesn't exist."))
 	  (else
 	   (if nph?
 	       (cgi-make-nph-response (run/port* doit))
 	       (cgi-make-response (run/port* doit) path req)))))
        
-       (else 
+       ((string=? request-method "HEAD")
-	(make-error-response (status-code method-not-allowed) req request-method))))))
+	    (make-error-response (status-code method-not-allowed) req "GET, POST"))
+       
+       (else
+	(make-error-response (status-code not-implemented) req))))))
+
+	
 
 
 (define (split-and-decode-search-spec s)
   (let recur ((i 0))
     (cond
-     ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
+     ((string-index s #\+ i) => (lambda (j) (cons (unescape s i j)
 						  (recur (+ j 1)))))
-     (else (list (unescape-uri s i (string-length s)))))))
+     (else (list (unescape s i (string-length s)))))))
 
 
 ;;; Compute the CGI scripts' process environment by adding the standard CGI
@@ -171,14 +175,14 @@
 	 (headers (request-headers req))
 
 	 ;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
-	 (path-info (uri-path->uri path-suffix)) ; No encode or .. check.
+	 (path-info (string-join 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->uri script-path)))
+	 (script-name (string-join script-path "/")))
 
     (receive (rhost rport)
 	     (socket-address->internet-address raddr)
@@ -201,7 +205,7 @@
 
 	  ,@request-invariant-cgi-env	; Stuff that never changes (see cgi-handler).
 
-	  ,@(cond ((http-url-search (request-url req)) =>
+	  ,@(cond ((http-url-query (request-url req)) =>
 		   (lambda (srch) `(("QUERY_STRING" . ,srch))))
 		  (else '()))
 
@@ -259,9 +263,8 @@
 		 (request-method req))
 
     (if loc
-	(if (uri-has-protocol? (string-trim loc))
+	(if (absolute-url? (url-string->http-url (string-trim loc)))
-	    (make-error-response (status-code moved-perm) req
+	    (make-error-response (status-code moved-perm) req loc)
-				      loc loc)
 	    (make-redirect-response (string-trim loc)))
 	;; Send the response header back to the client
 	(make-response ;code message seconds mime extras body
@@ -283,11 +286,6 @@
    (make-writer-body (lambda (out options)
 		       (copy-inport->outport script-port out)))))
 
-(define (uri-has-protocol? loc)
-  (receive (proto path search frag)
-      (parse-uri loc)
-    (if proto #t #f)))
-
 (define (extract-status-code-and-text status req)
   (with-fatal-error-handler*
    (lambda (c d)

scheme/httpd/core.scm

@@ -2,10 +2,6 @@
 
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
-;;; Copyright (c) 1996-2002 by Mike Sperber.
-;;; Copyright (c) 2000-2002 by Martin Gasbichler.
-;;; Copyright (c) 2002 by Andreas Bernauer.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
@@ -17,12 +13,13 @@
 ;;; a complete server, you need to define request handlers (see below) --
 ;;; they determine how requests are to be handled.
 ;;;
-;;; The RFC detailing the HTTP 1.0 protocol, RFC 1945, can be found at
+;;; See RFC 2616 for the specification of the HTTP/1.1 protocol.  
-;;; http://www.w3.org/Protocols/rfc1945/rfc1945
+;;;
+;;; The server is compatible with previous versions of HTTP in the way
+;;; described in RFC 2616 19.6. See RFC 1945 for the specification of
+;;; HTTP/1.0 and 0.9.
 
 
-(define server/protocol "HTTP/1.0")
-
 (define (httpd options)
   (let ((port (httpd-options-port options))
 	(root-dir (httpd-options-root-directory options))
@@ -154,23 +151,23 @@
 	     (values #f
 		     (apply make-error-response (status-code bad-request)
 			    #f		; No request yet.	
-			    "Request parsing error -- report to client maintainer."
 			    (condition-stuff c))))
 	    ((not (and (exception? c)
-		       (eq? (exception-reason c)
+		       (eq? (exception-reason c);;?? ->
-			    (enum exception os-error))))
+			    (enum exception os-error))));;?? ->
-
+	     ;;which cases is this supposed to catch excactly? broken
-	     ;; try to send bug report to client
+	     ;;connection to client? If so, does it work?
 	     (values #f
 		     (apply make-error-response (status-code internal-error) 
 			    #f		; don't know
-			    "Internal error occured while processing request"
 			    c)))
 	    (else
 	     (decline))))
 	 (lambda ()
 	   (let ((initial-req (parse-http-request sock options)))
-	     (let redirect-loop ((req initial-req))
+	     (check-major-http-version initial-req)
+	     (check-host-header initial-req)
+	     (let redirect-loop ((req initial-req)) 
 	       (let response-loop ((response ((httpd-options-request-handler options)
 					      (http-url-path (request-url req))
 					      req)))
@@ -181,7 +178,7 @@
 		     (socket:inport sock))))
 		  ((nph-response? response)
 		   (values req response))
-		  ((eq? (response-code response) (status-code redirect))
+		  ((eq? (response-code response) (status-code redirect));internal redirect
 		   (redirect-loop (redirect-request req response sock options)))
 		  (else
 		   (values req response)))))))))
@@ -193,6 +190,9 @@
 			    options)
 	)))))
 
+
+;;; REDIRECT-REQUEST relies on that nothing is read out from SOCKET.
+
 (define (redirect-request req response socket options)
   (let* ((new-location-uri (redirect-body-location (response-body response)))
 	 (url (with-fatal-error-handler*
@@ -206,7 +206,7 @@
 		 ;; (future) NOTE: With this, a redirection may change the
 		 ;; protocol in use (currently, the server only supports one of
 		 ;; it). This might be inapplicable.
-		 (parse-http-servers-url-fragment new-location-uri socket options)))))
+		 (url-string->http-url new-location-uri)))))
     
     (make-request "GET"
 		  new-location-uri
@@ -215,18 +215,7 @@
 		  '()			; no rfc822 headers
 		  (request-socket req))))
 
-;;;; HTTP request parsing
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; This code provides procedures to read requests from an input
-;;;; port.
-
 ;;; 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 options)
   (let ((line (read-crlf-line (socket:inport sock))))
@@ -250,46 +239,15 @@
 			  ((3) (parse-http-version (caddr elts)))
 			  (else (fatal-syntax-error "Bad Request Line."))))
 	       (meth (car elts))
-	       (uri-string (cadr elts))
+	       (request-uri (cadr elts))
-	       (url (parse-http-servers-url-fragment uri-string sock options))
+	       (url (url-string->http-url request-uri))
 	       (headers (if (equal? version '(0 . 9))
 			    '()
-			    (read-rfc822-headers (socket:inport sock)))))
+			    (with-fatal-error-handler
-	  (make-request meth uri-string url version headers sock)))))
+			     (lambda (c decline)
-
+			       (fatal-syntax-error "Illegal RFC 822 field syntax of request headers"))
-;;; Parse the URL, but if it begins without the "http://host:port"
+			     (read-rfc822-headers (socket:inport sock))))))
-;;; prefix, interpolate one from SOCKET. It would be sleazier but
+	  (make-request meth request-uri url version headers sock)))))
-;;; faster if we just computed the default host and port at
-;;; server-startup time, instead of on every request.
-;;; REDIRECT-REQUEST relys on that nothing is read out from SOCKET.
-
-(define (parse-http-servers-url-fragment uri-string socket options)
-  (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 server struct from our net connection.
-	    (if (and (pair? path) (string=? (car path) ""))
-		(let* ((addr (socket-local-address socket))
-		       (local-name (or (httpd-options-fqdn options)
-				       (socket-address->fqdn addr)))
-		       (portnum (or (httpd-options-reported-port options)
-				    (my-reported-port addr))))
-		  (make-http-url (make-server #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
@@ -303,6 +261,19 @@
 	    (lose vstring))))))
 				      
 
+;;; check whether the request's major HTTP version is greater than the
+;;; server's major HTTP version; if so, send 505 (Version not supported).
+
+(define (check-major-http-version req)
+  (if (> (car (request-version req)) (car http-version))
+      (http-error (status-code version-not-supp) req)))
+
+(define (check-host-header req)
+  (if (not (version< (request-version req) '(1 . 1)))
+      (or (get-header (request-headers req) 'host)
+	  (http-error (status-code bad-request) req "Missing Host header"))))
+
+
 ;;; 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
@@ -322,7 +293,7 @@
        (else '()))))
 
 (define (send-http-headers response port)
-  (display server/protocol port)
+  (display (version->string http-version) port)
   (write-char #\space port)
   (display (status-code-number (response-code response)) port)
   (write-char #\space port)
@@ -334,7 +305,8 @@
   (send-http-header-fields
    (list (cons 'server (string-append "Scheme Untergrund " sunet-version-identifier))
 	 (cons 'content-type (response-mime response))
-	 (cons 'date (rfc822-time->string (response-seconds response))))
+	 (cons 'date (rfc822-time->string (response-seconds response)))
+	 (cons 'connection "close"))
    port)
   (send-http-header-fields (response-extras response) port)
 
@@ -358,7 +330,8 @@
    (else 
     (if (not (v0.9-request? request))
 	(send-http-headers response output-port))
-    (if (not (string=? (request-method request) "HEAD"))
+    (if (not (or (string=? (request-method request) "HEAD")
+		 (no-body? (response-body response)))) ;; response messages which MUST NOT include a message-body
 	(display-http-body (response-body response) input-port output-port options))
     (http-log request (response-code response)))))
 
@@ -370,7 +343,3 @@
 	      (write-crlf port))
 	    headers))
 
-(define (my-reported-port addr)
-  (receive (ip-addr portnum) (socket-address->internet-address addr)
-    portnum))
-

scheme/httpd/error.scm

@@ -2,7 +2,6 @@
 
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 1995 by Olin Shivers.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
@@ -23,19 +22,37 @@
 
 (define http-error? (condition-predicate 'http-error))
 
+;; See make-error-response for what you have to stuff into args for
+;; each status-code. (All http-errors will be caught by the top-level
+;; error-handler of process-toplevel-request, and will be turned into
+;; calls of make-error-response).
 (define (http-error status-code req . args)
   (apply signal 'http-error status-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.
 
+
+;; fatal-syntax-error isn't really a different type of error - it's
+;; just an abbreviated notation:
+;; (fatal-syntax-error msg irritants) 
+;; is equivalent to
+;; (http-error (status-code bad-request) #f msg irritants)
+;; -> use fatal-syntax-error where the client request cannot be parsed
+;; because of bad syntax
+
 (define-condition-type 'fatal-syntax-error '(error))
 
 (define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
 
+;; as with http-errors fatal-syntax-errors will be caught by the
+;; top-level error-handler of process-toplevel-request and turned into
+;; calls of make-error-response
 (define (fatal-syntax-error msg . irritants)
   (apply signal 'fatal-syntax-error msg irritants))
 
+

scheme/httpd/file-dir-handler.scm

@@ -211,7 +211,7 @@
 ;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
 
 (define (make-rooted-file-path-response root file-path file-serve-response req options)
-  (if (http-url-search (request-url req))
+  (if (http-url-query (request-url req))
       (make-error-response (status-code bad-request) req
 			   "Indexed search not provided for this URL.")
       (cond ((dotdot-check root file-path) =>
@@ -252,17 +252,24 @@
 	       (send-file-response fname info req options))
 	      
 	      ((directory)		; Send back a redirection "foo" -> "foo/"
+	       (let* ((url (request-url req))
+		      (url-string (http-url->url-string url))
+		      (location-prefix 
+		       (if (absolute-url? url)
+			   url-string
+			   (string-append 
+			    "http://" (get-socket-host-string req) url-string))) ;we don't support virtual hosts yet!
+		      (location (string-append location-prefix "/")))
 	       (make-error-response
-		(status-code moved-perm) req
+		(status-code moved-perm) req location)))
-		(string-append (request-uri req) "/")
-		(string-append (http-url->string (request-url req))
-			       "/")))
 
 	      (else (make-error-response (status-code forbidden) req)))))
 	 
-	 (else 
+	 ((string=? request-method "POST")
 	  (make-error-response (status-code method-not-allowed) req 
-			       request-method))))))
+			        "GET, HEAD"))
+	 (else 
+	  (make-error-response (status-code not-implemented) req))))))
 
 (define (directory-index-serve-response fname file-path req options)
   (file-serve-response (string-append fname "index.html") file-path req options))
@@ -361,7 +368,7 @@
 	      ((directory) "[DIR ]")
 	      (else "[????]"))))
       (if icon-name
-	  (emit-tag port 'img
+	  (emit-empty-tag port 'img
 		    (cons 'src icon-name)
 		    (cons 'alt tag-name))
 	  (display tag-name port))
@@ -415,7 +422,8 @@
 		     (file-directory-options-back-icon-url options))
 		    (blank-icon
 		     (file-directory-options-blank-icon-url options)))
-		(with-tag port html ()
+		(emit-prolog port)
+		(with-tag port html (xmlnsdecl-attr)
 		  (let ((title (string-append "Index of /"
 					      (string-join file-path "/"))))
 		    (with-tag port head ()
@@ -425,16 +433,16 @@
 		      (with-tag port pre ()
 			(if blank-icon
 			    (display "[    ]" port)
-			    (emit-tag port 'img
+			    (emit-empty-tag port 'img
 				      (cons 'src blank-icon)
 				      (cons 'alt "      ")))
 			(write-string "Name                 " port)
 			(write-string "Last modified          " port)
 			(write-string "Size   " port)
 			(write-string "Description" port)
-			(emit-tag port 'hr)
+			(emit-empty-tag port 'hr)
 			(if back-icon
-			    (emit-tag port 'img
+			    (emit-empty-tag port 'img
 				      (cons 'src back-icon)
 				      (cons 'alt "[UP  ]"))
 			    (display "[UP  ]" port))
@@ -444,11 +452,14 @@
 				(write-string "Parent directory" port))
 			      (write-crlf port)))
 			(let ((n-files (directory-index req fname port options)))
-			  (emit-tag port 'hr)
+			  (emit-empty-tag port 'hr)
 			  (format port "~d files" n-files))))))))))))
-     (else
+	 
-      (make-error-response (status-code method-not-allowed) req 
+	 ((string=? request-method "POST")
-			   request-method)))))
+	  (make-error-response (status-code method-not-allowed) req 
+			       "GET, HEAD"))
+	 (else 
+	  (make-error-response (status-code not-implemented) req)))))
 
 (define (index-or-directory-serve-response fname file-path req options)
   (let ((index-fname (string-append fname "index.html")))

scheme/httpd/handler-lib.scm

@@ -0,0 +1,195 @@
+;;; A library of procs for request handlers.
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Reading in the message body of a request.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Read in the message body of an HTTP message and return it as a string.
+;;;
+;;; READ-MESSAGE-BODY handles ordinary message bodies as well as
+;;; message bodies to which the transfer coding "chunked" has been
+;;; applied.
+;;;
+;;; Note: all request handlers should use READ-MESSAGE-BODY, and should not
+;;; read in message bodies by themselves: READ-MESSAGE-BODY implements
+;;; the correct order in which a message body's length is determined.
+;;; (See RFC 2616, 4.4 for precedence of Transfer-encoding header over Content-length header.)
+
+(define (read-message-body req)
+  (let ((inport (socket:inport (request-socket req))))
+    (if (chunked-transfer-coding? req)
+	(read-chunked-body inport)
+	(read-ordinary-body inport req))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Reading in ordinary bodies (no transfer coding applied)
+
+
+;;; Read in the message body, return it as a string.
+
+(define (read-ordinary-body inport req)
+  (let* ((body-length (get-body-length-from-content-length req)) ;make sure we have a valid Content-length header in request
+	 (maybe-body (read-string body-length inport)))
+    (or maybe-body
+	(fatal-syntax-error "EOF while reading in message body"))))
+
+
+;;Get length of the request's message body from Content-length header or
+;;throw fatal-syntax-error if no such header
+
+(define (get-body-length-from-content-length req)
+  (let 
+      ;;try to get field value of first Content-length header (RFC 2616 allows only one Content-length: header)
+      ((maybe-length (get-numeric-field-value req 'content-length)))
+    (or maybe-length
+	(fatal-syntax-error "No Content-Length header in request"))))
+
+
+;; GET-NUMERIC-FIELD-VALUE
+;; generalized function to get a field value of the form 1*DIGIT
+;; req is a request record, field-name a symbol
+
+;; check wether a header-field with name field-name is contained in req;
+;; if not, return #f,
+;; else, take the first such header field and check wether its field-content conforms to 
+;; field-content = *LWS 1*DIGIT *LWS
+;; if so, return digit as a number
+
+(define (get-numeric-field-value req field-name)
+  (let 
+      ;;try to get first "field-name" header 
+      ((field-content (get-header (request-headers req) field-name)))
+    (if field-content ;; request contained "field-name" header
+	(let ;;see * below
+	    ((field-value (string->number (string-trim-both field-content char-set:blank)))) ;;char-set:blank = Space + Tab = LWS from RFC2616 after folding
+	  (if (and field-value (>= field-value 0)) ;;yes, field value contained only digits.
+	      field-value
+	      (fatal-syntax-error
+	       (format #f 
+		       "~A header contained only whitespace, or characters other than digits, or whitespace between digits" 
+		       field-name))))
+	#f)))
+;;* RFC 2616, 4.2: The field-content does not include any leading or
+;;trailing LWS: linear white space occurring before the first
+;;non-whitespace character of the field-value or after the last
+;;non-whitespace character of the field-value. Such leading or
+;;trailing LWS MAY be removed without changing the semantics of the
+;;field value.
+;;(probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Decoding chunked entity bodies: "chunked transfer-coding"
+
+
+;;; Is the request's entity body sent in chunked transfer-encoding?
+;;; (See RFC 2616, 14.41 and 3.6 for syntax and semantics of Transfer-Encoding header.)
+
+(define (chunked-transfer-coding? req)
+  (let ((field-value (get-header (request-headers req) 'transfer-encoding)))
+	(if (not field-value)
+	    #f
+
+		; the field value is a comma-separated list of transfer-codings (3.6),
+		; extract the last transfer-coding in the list
+	    (let* ((reversed-field-value (string-reverse field-value))
+		   (index ; does the list contain more than one element?
+		    (string-contains reversed-field-value " ,"))
+		   (last-transfer-coding
+		    (if index
+			(string-trim (string-reverse (string-take reversed-field-value index)))
+			(string-trim field-value)))) 
+
+               ; the first token of the (extracted last) transfer-coding must be "chunked" to indicate chunked transfer coding
+	      (string-prefix? "chunked" last-transfer-coding)))))
+
+
+
+;;; Read in the chunked entity body, return it as a string.
+;;; (See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.)
+
+(define (read-chunked-body inport)
+  (let read-chunks ((chunk-size (get-chunk-size inport))
+		    (res ""))
+    (if (= 0 chunk-size) ;last-chunk
+	(begin (discard-trailer inport); see comment *1
+	       res)
+	(let ((maybe-chunk-data (read-string chunk-size inport)))
+	  (if maybe-chunk-data
+	      (begin (discard-line-terminator inport)
+		     (read-chunks (get-chunk-size inport) (string-append res maybe-chunk-data)))
+	      (fatal-syntax-error "EOF while reading in chunk-data in chunked entity body"))))))
+
+;comment *1:
+;
+;This is were we don't achieve conditional compliance: we ought to read
+;in the entity-headers in the trailer and incorporate them into the
+;request record. Within our current scheme (where reading in the
+;entity-body is the request-handlers job - while the request-handler
+;is only called _after_ the request record has been built) this is not
+;possible.
+;
+;Note that in their current state (04/2005) the handlers actually
+;disregard most request headers anyway (even the request headers
+;parsed into the request record).
+;
+;Alternatively we could check the request for a Trailer header and
+;respond with 500 if we find one. Problem here: the clients "SHOULD
+;include a Trailer header field in a message using chunked
+;transfer-coding with a non-empty trailer" (14.40) - they are not
+;obliged to! So even if we check for a Trailer header we may still
+;silently disregard a trailer.
+
+
+;;;Read in a chunk-size line within a chunked entity body; return the chunk-size as an integer.
+;;; (See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.)
+
+(define (get-chunk-size inport)
+  (let ((chunk-size-line (read-crlf-line inport)))
+    (if (eof-object? chunk-size-line)
+	(fatal-syntax-error "EOF while reading in chunk-size in chunked entity body")
+	(let* ((chunk-extensions-index (string-contains chunk-size-line "; "))
+	       (hex-string (if chunk-extensions-index
+			       (string-take chunk-size-line chunk-extensions-index)
+			       chunk-size-line))
+	       (chunk-size-int (string->number (string-trim-both hex-string char-set:blank) 16)))
+	       (if (and chunk-size-int (>= chunk-size-int 0)) ; yes, chunk-size contained only hex chars
+		   chunk-size-int
+		   (fatal-syntax-error "Chunk-size within chunked entity body is incorrect or syntactically faulty"))))))
+
+(define (discard-trailer inport)
+  (with-fatal-error-handler
+   (lambda (c decline)
+     (fatal-syntax-error "Illegal RFC 822 field syntax within trailer of entity message body"))
+   (read-rfc822-headers inport)))
+
+(define (discard-line-terminator inport)
+ (read-char inport) (read-char inport)) ;;assuming the line terminator is CRLF as required by RFC 2616 
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; interpolate host info from our request's net connection.
+;; return string. Example: "134.2.12.72:7777"
+(define (get-socket-host-string req)
+  (let ((addr (socket-local-address (request-socket req))))
+    (call-with-values 
+	(lambda ()(socket-address->internet-address addr))
+      (lambda (ipaddr portnum) 
+	(string-append (format-internet-host-address ipaddr) ":" (number->string portnum))))))

scheme/httpd/handlers.scm

@@ -23,7 +23,7 @@
 ;;; lookup to determine how to implement a given operation on a particular
 ;;; path.
 ;;;
-;;; The REQUEST is a request record, as defined in httpd-core.scm, containing
+;;; The REQUEST is a request record, as defined in request.scm, containing
 ;;; the details of the client request.
 
 ;; general request handler combinator:
@@ -48,20 +48,14 @@
   (make-predicate-handler 
    (lambda (path req)
      ;; we expect only one host-header-field
-     (let ((body (string-trim (get-header (request-headers req) 'host))))
+     (let ((maybe-val (get-header (request-headers req) 'host)))
-       (or (string-ci=? hostname body)
+       (if maybe-val
-	   (string-prefix-ci? (string-append hostname ":") body))))
+	   (let ((val (string-trim  maybe-val)))
+	     (or (string-ci=? hostname val)
+		 (string-prefix-ci? (string-append hostname ":") val)))
+	   (http-error (status-code bad-request) req "No Host: header"))))
    handler default-handler))
 
-(define (get-header headers tag)
-  (cond
-   ((assq tag headers) => cdr)
-   (else
-    (http-error (status-code bad-request) #f
-		(string-append "Request did not contain "
-			       (symbol->string tag)
-			       " header")))))
-
 ;; selects handler according to path-prefix
 ;; if path-prefix matches, handler is called without the path-prefix
 (define (make-path-prefix-handler path-prefix handler default-handler)

scheme/httpd/info-gateway.scm

@@ -117,7 +117,7 @@
 	  ((list? parse-info)		; it's an info path
 	   (lambda (url)
 	     (values parse-info
-		     (unescape-uri (http-url-search url)))))
+		     (unescape (http-url-query url)))))
 	  (else
 	   (let ((info-path 
 		  ((infix-splitter ":") 
@@ -128,7 +128,7 @@
 			 "")))))
 	     (lambda (url)
 	       (values info-path
-		       (unescape-uri (http-url-search url))))))))
+		       (unescape (http-url-query url))))))))
 	(make-reference
 	 (cond
 	  ((procedure? reference) reference)
@@ -163,19 +163,21 @@
 	    '()
 	    (make-writer-body
 	     (lambda (out options)
-	   
+	       (emit-prolog out)
 	       (receive (find-entry node-name) (parse-info-url (request-url req))
 		 (display-node node-name
 			       (file-finder find-entry)
 			       (referencer make-reference (request-url req) out)
 			       icon-name
 			       out))
-	       (with-tag out address ()
+	       (with-tag out address ();; this is outside the html element?
 		 (write-string address out)))))))
-
+	 ((or (string=? request-method "HEAD")
-	 (else 
+	      (string=? request-method "POST"))
 	  (make-error-response (status-code method-not-allowed) req 
-				    request-method)))))))
+				    "GET"))
+	 (else
+	  (make-error-response (status-code not-implemented) req)))))))
 
 (define split-header-line
   (let ((split (infix-splitter (make-regexp "(, *)|(  +)|( *\t *)")))
@@ -232,7 +234,7 @@
       (string-append "(" file ")" node))))
 
 (define (display-icon file alt out)
-  (emit-tag out 'img
+  (emit-empty-tag out 'img
     (cons 'src file)
     (cons 'alt alt)
     (cons 'align "bottom")))
@@ -243,7 +245,7 @@
       (let ((file (or node-file file)))
 	(with-tag out a ((href (make-reference
 				old-entry
-				(escape-uri (unparse-node-name file node)))))
+				(escape-not-unreserved-chars (unparse-node-name file node)))))
 	  (if (and (not (null? maybe-icon))
 		   (car maybe-icon))
 	      (display-icon (car maybe-icon) (cadr maybe-icon) out))
@@ -280,18 +282,18 @@
   (emit-title out (string-append "Info Node: "
 				(unparse-node-name file node)))
   (with-tag out h1 ()
-	    (emit-tag out 'img
+	    (emit-empty-tag out 'img
 		      (cons 'src (icon-name 'info))
 		      (cons 'alt "Info Node")
 		      (cons 'align 'bottom))
 	    (write-string (unparse-node-name file node) out))
-  (emit-tag out 'hr)
+  (emit-empty-tag out 'hr)
   (maybe-display-header next (icon-name 'next) "[Next]")
   (maybe-display-header previous (icon-name 'previous) "[Previous]")
   (maybe-display-header up (icon-name 'up) "[Up]")
 	 
   (if (or next previous up)
-      (emit-tag out 'hr)))
+      (emit-empty-tag out 'hr)))
 
 ;; Text
 
@@ -438,7 +440,7 @@
     (receive (port file-header node-header up-header prev-header next-header)
 	(find-node file node find-file)
     
-      (with-tag out html ()
+      (with-tag out html (xmlnsdecl-attr)
 	(with-tag out head ()
 	  (display-title file node-header up-header
 			 prev-header next-header

scheme/httpd/logging.scm

@@ -123,8 +123,8 @@
 			   (socket-remote-address (request-socket req)))
 			(format-internet-host-address host-address))
 		      (request-method req) ; request method
-		      (uri-path->uri
+		      (http-url-path->path-string
-		       (http-url-path (request-url req))) ; requested file
+		       (http-url-path (request-url req))) ; requested file (escaped as it was in original request)
 		      (version->string (request-version req)) ; protocol version
 		      (status-code-number status-code)
 		      23		; filesize (unknown)
@@ -169,11 +169,21 @@
 		(or (maybe-dns-lookup remote-ip) "-")
 		(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date))     ; +0000 as we don't know
 		(string-join (list request-type 
-				   (string-append "/" requested-file) 
+				   requested-file 
 				   protocol))
 		; Unfortunately, we first split the request line into 
 		; method/request-type etc. and put it together here.
 		; Files conform to CLF are expected to print the original line.
+
+                ; --> Shouldn't be a problem: the original request
+                ; line is reconstructed almost completely:
+                ; requested-file (i.e. http-url->url-string url) is
+                ; exactly the original Request_URI (apart from
+                ; multiple slashes, which are thrown away),
+		; request-type and protocol are the original.  
+		; --> Only number of slashes in Request_URI and
+		; whitespace between parts of Request-Line can differ.
+
 		(or http-code "-")
 		(or filesize "-")
 		(if (string? referer) (string-trim referer) '-)

scheme/httpd/request.scm

@@ -1,7 +1,7 @@
 ;;;; HTTP request
 
 ;;; This file is part of the Scheme Untergrund Networking package.
-;;; Copyright (c) 1996 by Olin Shivers.
+
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
@@ -10,7 +10,7 @@
 (define-record-type request :request
   (make-request method uri url version headers socket)
   request?
-  (method request-method)		; A string such as "GET", "PUT", etc.
+  (method request-method)		; A string such as "GET", "POST", etc.
   (uri request-uri)			; The escaped URI string as read from request line.
   (url request-url)			; An http URL record (see url.scm).
   (version request-version)		; A (major . minor) integer pair.
@@ -26,6 +26,7 @@
 	  (request-version req)
 	  (request-headers req)
 	  (request-socket req))))
+
 ;;; A http protocol version is an integer  pair: (major . minor).
 
 (define (version< v1 v2)

scheme/httpd/response.scm

@@ -1,10 +1,10 @@
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
-;;; Copyright (c) 2002 by Mike Sperber.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
+(define http-version '(1 . 1));server's HTTP-version is only hardcoded here!
+
 (define-record-type http-response :http-response
   (make-response code message seconds mime extras body)
   response?
@@ -21,6 +21,12 @@
 			  ;;representing the field value.
   (body response-body));; message-body
 
+;;TODO: mime shouldn't be a field in http-response, because it needn't be present for
+;;responses which don't include a message-body.
+;;Instead treat mime-type like any other header.
+;;(Not urgent, as RFC 2616 doesn't prohibit presence of Content-Type header field 
+;;in body-less responses).
+
 ;; This is mainly for nph-... CGI scripts.
 ;; This means that the body will output the entire MIME message, not
 ;; just the part after the headers.
@@ -40,6 +46,15 @@
   writer-body?
   (proc writer-body-proc))
 
+;; the concept of http-reader-writer-body doesn't work: status-line
+;; and headers of the response (i.e. the whole http-response record)
+;; have to be built _before_ we have seen the entity-body of the
+;; request. (Not until display-http-body hands over the iport to
+;; reader-writer-body the entity-body can be read in). If the
+;; entity-body is erroneous or if we encounter a server internal error
+;; while reading in the entity-body we are not able to send an
+;; appropriate response. (At that point of time we already sent
+;; status-line and response-headers!)
 (define-record-type http-reader-writer-body :http-reader-writer-body
   (make-reader-writer-body proc)
   reader-writer-body?
@@ -50,6 +65,14 @@
   redirect-body?
   (location redirect-body-location))
 
+;; type for responses which MUST NOT include a body (101, 204, 304)
+(define-enumerated-type no-body :no-body
+  no-body?
+  no-body-elements
+  no-body-name
+  no-body-index
+  (none))
+
 (define (display-http-body body iport oport options)
   (cond
    ((writer-body? body)
@@ -66,36 +89,56 @@
   (number status-code-number)
   (message status-code-message)
   (
+   (continue		100 "Continue")
+   (switch-protocol	101 "Switching Protocols")
+
    (ok			200 "OK")
    (created		201 "Created")
    (accepted		202 "Accepted")
-   (prov-info		203 "Provisional Information")
+   (non-author-info	203 "Non-Authoritative Information")
    (no-content		204 "No Content")
+   (reset-content	205 "Reset Content")
+   (partial-content	206 "Partial Content")
 
    (mult-choice		300 "Multiple Choices")
    (moved-perm		301 "Moved Permanently")
-   (moved-temp		302 "Moved Temporarily")
+   (found		302 "Found");;use 303 or 307 for unambiguity;
-   (method		303 "Method (obsolete)")
+				    ;;use 302 for compatibility with
+				    ;;pre-1.1-clients
+   (see-other		303 "See other");;client is expected to
+					;;perform a GET on new URI
    (not-mod		304 "Not Modified")
+   (use-proxy		305 "Use Proxy")
+   (temp-redirect	307 "Temporary Redirect");;analogous to "302
+						 ;;Moved Temporarily"
+						 ;;in RFC1945
 
    (bad-request		400 "Bad Request")
    (unauthorized	401 "Unauthorized")
-   (payment-req		402 "Payment Required")
+   (payment-required	402 "Payment Required")
    (forbidden		403 "Forbidden")
    (not-found		404 "Not Found")
    (method-not-allowed	405 "Method Not Allowed")
-   (none-acceptable	406 "None Acceptable")
+   (not-acceptable	406 "Not Acceptable")
    (proxy-auth-required	407 "Proxy Authentication Required")
    (timeout		408 "Request Timeout")
    (conflict		409 "Conflict")
-   (gone			410 "Gone")
+   (gone		410 "Gone")
+   (length-required	411 "Length Required")
+   (precon-failed	412 "Precondition Failed")
+   (req-ent-too-large	413 "Request Entity Too Large")
+   (req-uri-too-large	414 "Request URI Too Large")
+   (unsupp-media-type	415 "Unsupported Media Type")
+   (req-range-not-sat	416 "Requested Range Not Satisfiable")
+   (expectation-failed	417 "Expectation Failed")
 
    (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")
-  
+   (version-not-supp	505 "HTTP Version Not Supported")  
+
    (redirect             -301 "Internal redirect")))
 
 (define (name->status-code name)
@@ -122,147 +165,183 @@
 	      (else
 	       (loop (+ i 1)))))))
 	
-;;; (make-error-response status-code req [message . extras])
+;;; (make-error-response status-code req [extras])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; 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
+;;; even had a chance to parse and construct the request. This can be the case for 
-;;; for 400 BAD-REQUEST error report.
+;;; internal-error, bad-request, (possibly bad-gateway and ...?)
 
-(define (make-error-response code req . args)
-  (let* ((message (and (pair? args) (car args)))
-	 (extras  (if (pair? args) (cdr args) '()))
 
-	 (generic-title (lambda (port)
+(define (make-error-response code req . extras)
-			  (title-html port
+  (let*
-				      (status-code-message code))))
+      ;;catch server internal errors coming off by calls of make-error-response with too few arguments
-	 (send-message (lambda (port)
+      ((assert (lambda (n) 
-			 (if message 
+		 (if (< (length extras) n)
-			     (format port "<BR>~%Further Information: ~A<BR>~%" message))))
+		     (make-error-response (status-code internal-error) req
-	 (close-html (lambda (port)
+				 "Too few arguments to make-error-response"))))
-		       (for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
+       (generic-title (lambda (port)
-		       (write-string "</BODY>\n" port)))
+			(title-html port
-			
+				    (status-code-message code))))
-	 (create-response
+       (close-html (lambda (port args)
-	  (lambda (headers writer-proc)
+		     (if (not (null? args))
-	    (make-response code
+			 (format port "<br/>~%Further Information:~%"))
-			   #f
+		     (for-each (lambda (x) (format port "<br/>~%~A~%" x)) args)
-			   (time)
+		     (format port "</p>~%</body>~%</html>~%")))
-			   "text/html"
+       		
-			   headers
+       (create-response
-			   (make-writer-body writer-proc)))))
+	(lambda (headers body)
+	  (make-response code
+			 #f
+			 (time)
+			 "text/html"
+			 headers
+			 body)))
+
+       (create-writer-body-response
+	(lambda (headers writer-proc)
+	  (create-response headers (make-writer-body writer-proc))))
+
+       (create-no-body-response
+	(lambda (headers)
+	  (create-response headers (no-body none)))))
 
     (cond
-     ;; This error response requires two args: message is the new URI: field,
+
-     ;; and the first EXTRA is the older Location: field.
+     ;;this response requires one arg:
-     ((or (eq? code (status-code moved-temp))
+     ;;the value of the Upgrade field header,
-	  (eq? code (status-code moved-perm)))
+     ;;which must be a string listing the protocols which are being switched
-      (create-response
+     ;;for example "HTTP/2.0, IRC/6.9"
-       (list (cons 'uri message)
+     ((eq? code (status-code switch-protocol));; server currently doesn't have ability to switch protocols
-	     (cons 'location (car extras)))
+      (assert 1)
+      (create-no-body-response
+       (list (cons 'upgrade (car extras))
+	     (cons 'connection "upgrade")))) ;; need this, because Upgrade header field only applies to immediate connection
+      
+     ((eq? code (status-code no-content))
+      (create-no-body-response '()))
+
+     ;; This error response requires one arg:
+     ;; the value of the Location field header,
+     ;; which must be a single absolute URI
+     ((or (eq? code (status-code found));302
+	  (eq? code (status-code see-other));303
+	  (eq? code (status-code temp-redirect));307
+	  (eq? code (status-code moved-perm)));301
+      (assert 1)
+      (create-writer-body-response
+       (list (cons 'location (car extras)))
        (lambda (port options)
 	 (title-html port "Document moved")
 	 (format port
-		 "This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
+		 "The requested resource has moved ~A to a <a href=\"~A\">new location</a>.~%"
-		 (if (eq? code (status-code moved-temp))
+		 (if (eq? code (status-code moved-perm))
-		     "temporarily"
+		     "permanently"
-		     "permanently")
+		     "temporarily")
-		 message)
+		 (car extras))
-	 (close-html port))))
+	 (close-html port (cdr extras)))))
 
-     ((eq? code (status-code bad-request))
+     ((eq? code (status-code not-mod))
-      (create-response
+      (create-no-body-response '())) ;;see RCF 2616 10.3.5: this is only a valid answer if the server never sends
+                                     ;;any of the headers Expires, Cache-Control, Vary for this resource
+
+     ((eq? code (status-code bad-request)) 
+      (create-writer-body-response 
        '()
-       (lambda (port options)
+       (lambda (port options) 
-	 (generic-title port)
+	 (generic-title port) 
-	 (write-string "<P>Client sent a query that this server could not understand.\n"
+	 (format port "The request the client sent could not be understood by this server due to malformed syntax.~% Report to client maintainer.~%")
-		       port)
+	 (close-html port extras))))
-	 (send-message port)
-	 (close-html port))))
 
+     ;; This error response requires one arg:
+     ;; the value of the Allow field header,
+     ;; which must be a string listing the valid methods for the requested resource
+     ;; Ex.: "GET, HEAD, POST"
      ((eq? code (status-code method-not-allowed))
-      (create-response
+      (assert 1)
-       '()
+      (create-writer-body-response
+       (list (cons 'allow (car extras)))
        (lambda (port options)
 	 (generic-title port)
-	 (write-string "<P>Method not allowed.\n" port)
+	 (format port "The method ~A is not allowed on the requested resource ~A.~%" 
-	 (send-message port)
+		 (request-method req) (http-url->url-string (request-url req)))
-	 (close-html port))))
+	 (close-html port (cdr extras)))))
 
+     ;; This error response requires one arg:
+     ;; the value of the WWW-Authenticate header field,
+     ;; which must be a challenge (as described in RFC 2617)
      ((eq? code (status-code unauthorized))
-      (create-response
+      (assert 1)
-       (list (cons 'WWW-Authenticate message)) ; Vas is das? 
+      (create-writer-body-response
-       ;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
+       (list (cons 'WWW-Authenticate (car extras))) 
-       ;; message should be a challenge(?)
        (lambda (port options)
-	 (title-html port "Authorization Required")
+	 (title-html port "Authentication Required")
-	 (write-string "<P>Browser not authentication-capable or\n" port)
+	 (format port "Client not authentication-capable or authentication failed.~%")
-	 (write-string "authentication failed.\n" port)
+	 (close-html port (cdr extras)))))
-	 (send-message port)
-	 (close-html port))))
 
      ((eq? code (status-code forbidden))
-      (create-response
+      (create-writer-body-response
        '()
        (lambda (port options)
 	 (title-html port "Request not allowed.")
-	 (format port 
+	 (format port "The request the client sent is not allowed.~% Retrying won't help.~%")
-		 "Your client does not have permission to perform a ~A~%"
+	 (close-html port extras))))
-		 (request-method req))
-	 (format port "operation on url ~a.~%" (request-uri req))
-	 (send-message port)
-	 (close-html port))))
        
      ((eq? code (status-code not-found))
-      (create-response
+      (create-writer-body-response
        '()
        (lambda (port options)
-	 (title-html port "URL not found")
+	 (title-html port "Resource not found")
-	 (write-string 
+	 (format port "The requested resource ~A was not found on this server.~%" 
-	  "<P>The requested URL was not found on this server.\n"
+		 (http-url->url-string (request-url req)))
-	  port)
+	 (close-html port extras))))
-	 (send-message port)
-	 (close-html port))))
 
      ((eq? code (status-code internal-error))
-      (create-response
+      (create-writer-body-response
        '()
        (lambda (port options)
 	 (generic-title port)
-	 (format port "The server encountered an internal error or
+	 (format port "This server encountered an internal error or misconfiguration and was unable to complete your request.~%<br/>~%Please inform the server administrator ~A of the circumstances leading to the error, and the time it occured.~%"
-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.~%"
 		 (or (httpd-options-server-admin options)
 		     "[no mail address available]"))
-	 (send-message port)
+	 (close-html port extras))))
-	 (close-html port))))
+
-      
      ((eq? code (status-code not-implemented))
-      (create-response
+      (create-writer-body-response
        '()
        (lambda (port options)
 	 (generic-title port)
-	 (format port "This server does not currently implement 
+	 (format port "This server does not recognize or does not implement the requested method ~A.~%"
-the requested method (~A).~%"
 		 (request-method req))
-	 (send-message port)
+	 (close-html port extras))))
-	 (close-html port))))
 
      ((eq? code (status-code bad-gateway))
-      (create-response
+      (create-writer-body-response
        '()
        (lambda (port options)
 	 (generic-title port)
-	 (format port "An error occured while waiting for the 
+	 (format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
-response of a gateway.~%")
+	 (close-html port extras))))
-	 (send-message port)
-	 (close-html port)))))))
 
+     ((eq? code (status-code version-not-supp))
+      (create-writer-body-response
+       '()
+       (lambda (port options)
+	 (generic-title port)
+	 (format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is 1.~%"
+		 (car (request-version req)))
+;	 (format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is ~D.~%"
+;		 (car (request-version req))
+;		 (car http-version))
+	 (close-html port extras)))))))
+
+  
 (define (title-html out message)
-  (format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
+  ;;produce valid XHTML 1.0 Strict
-  (format out "<BODY>~%<H1>~A</H1>~%" message))
+  (emit-prolog out)
+  (emit-tag out 'html xmlnsdecl-attr)
+  (format out "~%<head>~%<title>~%~A~%</title>~%</head>~%" message)
+  (format out "<body>~%<h1>~A</h1>~%<p>~%" message))
 
 ;; Creates a redirect response. The server will serve the new file
 ;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and
@@ -270,7 +349,7 @@ response of a gateway.~%")
 ;; the browser won't notice the redirect. Thus, it will keep the
 ;; original URL. For "real" redirections, use 
 ;; (make-error-response (status-code moved-perm) req 
-;;                      "new-location" "new-location").
+;;                      "new-location").
 (define (make-redirect-response new-location)
   (make-response
    (status-code redirect)

scheme/httpd/rman-gateway.scm

@@ -20,7 +20,7 @@
 	  ((list? finder)
 	   (lambda (url)
 	     (values finder
-		     (unescape-uri (http-url-search url))
+		     (unescape (http-url-query url))
 		     '())))
 	  (else
 	   (let ((man-path 
@@ -32,7 +32,7 @@
 			 "")))))
 	     (lambda (url)
 	       (values man-path
-		       (unescape-uri (http-url-search url))
+		       (unescape (http-url-query url))
 		       '()))))))
 	(reference-template
 	 (cond
@@ -62,17 +62,22 @@
 	    '()
 	    (make-writer-body
 	     (lambda (out options)
+	       (emit-prolog out)
 	       (receive (man-path entry and-then) 
 		   (parse-man-url (request-url req))
 		 (emit-man-page man-binary nroff-binary rman-binary
 				gzcat-binary
 				entry man man-path and-then reference-template out))
 	       
-	       (with-tag out address ()
+	       (with-tag out address () ;;außerhalb des html elements?
 		 (display address out)))))))
-	 (else 
+	 ((or (string=? request-method "HEAD")
+	      (string=? request-method "POST"))
 	  (make-error-response (status-code method-not-allowed) req 
-				    request-method)))))))
+			       "GET"))
+	 (else
+	  (make-error-response (status-code not-implemented) req)))))))
+
 
 (define (cat-man-page key section out)
   (let ((title (if section

scheme/httpd/seval.scm

@@ -38,69 +38,73 @@
     (cond 
      ((string=? request-method "POST")	; Could do others also.
       (seval path req))
+     ((or (string=? request-method "HEAD")
+	  (string=? request-method "GET"))
+      (make-error-response (status-code method-not-allowed) req 
+				    "POST"))
      (else
-      (make-error-response (status-code method-not-allowed) req request-method)))))
+      (make-error-response (status-code not-implemented) req)))))
+
 
 (define (seval path req)
+  (let* ((message-body (read-message-body req))
+	(sexp (parse-request-sexp message-body)))
     (make-response
      (status-code ok)
      #f
      (time)
      "text/html"
      '()
-     (make-reader-writer-body
+     (make-writer-body
-      (lambda (iport oport options)
+      (lambda (oport options)
-	(let ((sexp (read-request-sexp req iport)))
+	(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
-	  (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
+	(emit-prolog oport)
-	  (with-tag oport HEAD ()
+	(with-tag oport html (xmlnsdecl-attr)
-	    (newline oport)
+		  (newline oport)
-	    (emit-title oport "Scheme program output"))
+		  (with-tag oport head ()
-	  (newline oport)
+			    (newline oport)
-	  
+			    (emit-title oport "Scheme program output")
-	  (with-tag oport BODY ()
+			    (newline oport))
-	    (newline oport)
+		  (newline oport)
-	    (do/timeout 
+		  
-	     10
+		  (with-tag oport body ()
-	     (receive vals
+			    (newline oport)
-		 ;; Do the computation.
+			    (do/timeout 
-		 (begin (emit-header oport 2 "Output from execution")
+			     10
-			(newline oport)
+			     (receive vals
-			(with-tag oport PRE ()
+				      ;; Do the computation.
-			  (newline oport)
+				      (begin (emit-header oport 1 "Output from execution")
-			  (force-output oport); In case we're gunned down.
+					     (newline oport)
-			  (with-current-output-port oport
+					     (with-tag oport pre ()
-			      (eval-safely sexp))))
+						       (newline oport)
-	       
+						       (force-output oport); In case we're gunned down.
-	       ;; Pretty-print the returned value(s).
+						       (with-current-output-port oport
-	       (emit-header oport 2 "Return value(s)")
+										 (eval-safely sexp))))
-	       (with-tag oport PRE ()
+				      
-		 (for-each (lambda (val) (p val oport))
+				      ;; Pretty-print the returned value(s).;; hier noch mal newline rausschreiben?
-			   vals))))))))))
+				      (emit-header oport 1 "Return value(s)")
+				      (with-tag oport pre ()
+						(for-each (lambda (val) (p val oport))
+							  vals)))))))))))
 
 
-;;; Read an HTTP request entity body from stdin. The Content-length:
+;;; Parse the request's message body.
-;;; element of request REQ's header tells how many bytes to this entity
-;;; is. The entity should be a URI-encoded form body. Pull out the
-;;;     program=<stuff>
-;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
-;;; and return it.
 
-(define (read-request-sexp req iport)
+;;; We assume, that the entity is "form-url encoded" data (see
-  (cond 
+;;; parse-forms.scm for a description of this encoding). This
-   ((get-header (request-headers req) 'content-length) =>
+;;; assumption is rather strange - it may safely be made only if
-    (lambda (cl-str)		 ; Take the first Content-length: header,
+;;; there's a "Content-type: application/x-www-form-urlencoded" header.
-      (let* ((cl-start (string-skip cl-str char-set:whitespace))	   ; skip whitespace,
-	     (cl (if cl-start			   	   ; & convert to
-		     (string->number (substring cl-str   ;     a number.
-						cl-start
-						(string-length cl-str)))
-		     0)) ; All whitespace?? -- WTF.
-	     (qs (read-string cl iport))			; Read in CL chars,
-	     (q (parse-html-form-query qs))		; and parse them up.
-	     (s (cond ((assoc "program" q) => cdr)
-		      (else (error "No program in entity body.")))))
-	(http-syslog (syslog-level debug)
-		     "Seval sexp: ~s" s)
-	(read (make-string-input-port s)))))
-   (else (error "No `Content-length:' field in POST request."))))
 
+;;; Pull out the program=<stuff> string, extract <stuff>, 
+;;; parse that into an s-expression, and return it.
+
+(define (parse-request-sexp body)
+  (let* ((parsed-html-form-query (parse-html-form-query body))
+	 (program (cond ((assoc "program" parsed-html-form-query) => cdr)
+		      (else (fatal-syntax-error "No program was found in request's message body.")))))
+    (http-syslog (syslog-level debug)
+		 "Seval sexp: ~s" program)
+    (with-fatal-error-handler 
+     (lambda (c decline)
+       (fatal-syntax-error "The program in the request's message body isn't a valid s-expression"))
+     (read (make-string-input-port program))))) ;; return first sexp, discard others

scheme/httpd/surflets/bindings.scm

@@ -26,7 +26,7 @@
 'application/x-www-form-urlencoded' as content-type"))
     (cond
      ((string=? request-method "GET")
-      (form-query-list (http-url-search 
+      (form-query-list (http-url-query 
 			(surflet-request-url surflet-request))))
      ((string=? request-method "POST")
       (or (cached-bindings surflet-request)

scheme/httpd/surflets/packages.scm

@@ -443,6 +443,7 @@
 	shift-reset			;SHIFT and RESET
         (subset srfi-1 (alist-cons alist-delete!))
 	srfi-6				;string-ports
+	(subset srfi-13 (string-join))
 	srfi-14				;CHAR-SET:DIGIT
 	srfi-27				;random numbers
 	surflet-requests		;requests for surflets
@@ -626,7 +627,6 @@
 (define-structure surflets/addresses surflets/addresses-interface
   (open scheme
 	srfi-23				;error
-	(subset uri (escape-uri))
 	define-record-types
 	(subset surflets/utilities (generate-unique-name)))
   (files addresses))
@@ -644,7 +644,7 @@
   (open scheme
 	surflets/input-field-value
 	surflets/addresses
-	(subset uri (unescape-uri)))
+	(subset uri (unescape)))
   (files returned-via))
 
 (define-structure surflets/outdaters surflets/outdaters-interface
@@ -659,7 +659,7 @@
 	weak				;weak pointers
 	surflets/utilities		;form-query-list
 	surflet-requests
-	(subset url (http-url-search))
+	(subset url (http-url-query))
 	(subset srfi-14 (char-set:digit))
 	(subset srfi-13 (string-index string-trim))
 	(subset srfi-1 (filter))

scheme/httpd/surflets/surflet-handler.scm

@@ -44,7 +44,7 @@
   (lambda (path req)
     (if (pair? path)			; need at least one element
 	(let ((request-method (request-method req))
-	      (path-string (uri-path->uri path)))
+	      (path-string (string-join path "/")))
 	  (if (or (string=? request-method "GET")
 		  (string=? request-method "POST"))
 	      (make-input-response

scheme/lib/htmlout.scm

@@ -11,6 +11,34 @@
 ;;;   HTML text representation -- surrounding it with single or double quotes,
 ;;;   as appropriate, etc.
 
+
+;;XHTML 1.0 Strict
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; a well-formed XML document begins with a prolog;
+;; this is the prolog for an XHTML 1.0 strict document:
+
+(define XMLdecl 
+  "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
+
+(define doctypedecl 
+  "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") 
+
+(define (emit-prolog out)
+  (display XMLdecl out)
+  (newline out)
+  (display doctypedecl out)
+  (newline out))
+
+;; the root element html must contain an xmlns declaration for the
+;; XHTML namespace, which ist defined to be
+;; http://www.w3.org/1999/xhtml
+
+(define xmlnsval "http://www.w3.org/1999/xhtml")
+
+;; for use with emit-tag and with-tag:
+(define xmlnsdecl-attr (cons 'xmlns xmlnsval))
+
 ;;; Printing HTML tags.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; All the emit-foo procedures have the same basic calling conventions:
@@ -42,6 +70,26 @@
 	      attrs)
     (display #\> out)))
 
+;;; Empty elements, e.g. <hr />
+
+(define (emit-empty-tag out tag . attrs)
+  (let ((out (fmt->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)
+    (display #\> out)))
+
+
 
 ;;; </tag>
 
@@ -49,7 +97,7 @@
   (format out "</~a>" tag))
 
 
-;;; <P>
+;;; <p>
 
 (define (emit-p . args)		; (emit-p [out attr1 ...])
   (receive (out attrs) (if (pair? args)
@@ -61,13 +109,13 @@
     (apply emit-tag out 'p attrs)))
 
 
-;;; <TITLE> Make Money Fast!!! </TITLE>
+;;; <title> Make Money Fast!!! </title>
 
 (define (emit-title out title)			; Takes no attributes.
-  (format out "<title>~a~%</title>~%" title))
+  (format out "<title>~a</title>" title))
 
 (define (emit-header out level text . attribs)
-  (apply with-tag* out (string-append "H" (number->string level))
+  (apply with-tag* out (string-append "h" (number->string level))
 	 (lambda () (display text (fmt->port out)))
 	 attribs))
 	     
@@ -90,11 +138,11 @@
 ;;; instead of (NAME VALUE).
 ;;;
 ;;; For example,
-;;;     (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page.
+;;;     (let ((hp-url "http://clark.lcs.mit.edu/~shivers")) ; My home page.
-;;;       (with-tag port A ((href hp-url) (name "hp"))
+;;;       (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>
+;;;     <a href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</a>
 
 (define-syntax with-tag
   (syntax-rules ()
@@ -107,9 +155,11 @@
 ;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
 
 (define-syntax %hack-attr-elt 
-  (syntax-rules ()			; Build attribute-list element:
+  (syntax-rules (xmlnsdecl-attr)			; Build attribute-list element:
     ((%hack-attr-elt (name val))	; (name elt) => (cons 'name elt)
      (cons 'name val))
+    ((%hack-attr-elt xmlnsdecl-attr)
+     xmlnsdecl-attr)
     ((%hack-attr-elt name) 'name)))	; name => 'name
 
 
@@ -191,3 +241,4 @@
   (if (null? maybe-port)
       (write-string (escape-html s))
       (write-string (escape-html s) (fmt->port (car maybe-port)))))
+

scheme/lib/parse-forms.scm

@@ -12,12 +12,12 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 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
+;;; where the <name> and <val> parts are URI encoded to hide their &,
-;;; &, =, and + chars, among other things. After URI encoding, the
+;;; =, and + chars and other reserves or excluded characters. After
-;;; space chars are converted to + chars, just for fun. It is important
+;;; URI encoding, the space chars are converted to + chars, just for
-;;; to encode the spaces this way, because the perfectly general %xx escape
+;;; fun. It is important to encode the spaces this way, because the
-;;; mechanism might be insufficiently confusing. This variant encoding is
+;;; perfectly general %xx escape mechanism might be insufficiently
-;;; called "form-url encoding."
+;;; 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.,
@@ -32,6 +32,7 @@
 ;;;
 ;;; In either case, the data is "form-url encoded" (as described above).
 
+
 (define (parse-html-form-query q)
   (let ((qlen (string-length q)))
     (let recur ((i 0))
@@ -46,11 +47,11 @@
        (else '())))))			; BOGUS STRING -- Issue a warning.
 
 
-;;; Map plus characters to spaces, then do URI decoding.
+;;; Map plus characters to spaces, then unescape.
 (define (unescape-uri+ s . maybe-start/end)
   (let-optionals maybe-start/end ((start 0)
 				  (end (string-length s)))
-    (unescape-uri (string-map (lambda (c) (if (char=? c #\+) #\space c))
+    (unescape (string-map (lambda (c) (if (char=? c #\+) #\space c))
 			      (if (and (zero? start)
 				       (= end (string-length s)))
 				  s	; Gratuitous optimisation.

scheme/lib/sunet-utilities.scm

@@ -2,10 +2,10 @@
 
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 2002 by Andreas Bernauer.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
+;;; interpolate hostname or IP address from socket local address. return a string
 (define (host-name-or-ip addr)
   (with-fatal-error-handler
    (lambda (condition more)
@@ -68,7 +68,6 @@
    (lambda ()
      (release-lock lock))))
 
-
 ;; Get Header from (RFC822 like) header alist
 (define (get-header headers tag)
   (cond ((assq tag headers) => cdr)

scheme/lib/uri.scm

@@ -3,93 +3,51 @@
 ;;; This file is part of the Scheme Untergrund Networking package.
 
 ;;; Copyright (c) 1995 by Olin Shivers.
+;;; Copyright (c) 2004 by Viola Brunner.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
-;;; URI syntax -- [scheme] : path [? search ] [# fragmentid]
-
 ;;; References:
-;;; - http://www.w3.org/Addressing/rfc1630.txt
+;;; RFC 2396 Uniform Resource Identifiers (URI): Generic Syntax
-;;;   Original RFC
-;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/URI_Overview.html
-;;;   General Web page of URI pointers.
 
-(define uri-reserved (string->char-set ";/#?: ="))
 
-(define uri-reserved-sans-= (char-set-delete uri-reserved #\=))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; decode a URI
+;;; walk over string s and unescape all occurrences of RegExp 'escaped' (see url.scm).
 
-(define (parse-uri s)
+;copy from url.scm:
-  (let* ((slen (string-length s))
+(define hex (rx hex-digit))
-	 ;; Search forwards for colon (or intervening reserved char).
+(define escaped (rx (: "%" ,hex ,hex)))
-	 (rs1 (string-index s uri-reserved))	; 1st reserved char
-	 (colon (and rs1 (char=? (string-ref s rs1) #\:) rs1))
-	 (path-start (if colon (+ colon 1) 0))
 
-	 ;; Search backwards for # (or intervening reserved char).
+;;; Remark: 
-	 (rs-last (string-index-right s uri-reserved))
+;;; we assume no non-ASCII characters occur in the URI; therefore the
-	 (sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last))
+;;; ascii table is used for conversion of the octet the hexnumber
-
+;;; represents to a char.
-	 ;; Search backwards for ? (or intervening reserved char).
-	 ;; (NB: #\= may be after #\? and before #\#)
-	 (rs-penult (string-index-right s                      
-					uri-reserved-sans-=
-					path-start
-					(or sharp slen)))
-	 (ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult))
-
-	 (path-end (or ques sharp slen)))
-    (values (and colon (substring s 0 colon))
-	    (split-uri s path-start path-end)
-	    (and ques (substring s (+ ques 1) (or sharp slen)))
-	    (and sharp (substring s (+ sharp 1) slen)))))
 
 ;;; Caution:
-;;; Don't use this proc until *after* you've parsed the URL -- unescaping
+;;; a URI must be separated into its components (for a HTTP-URL e.g. parsed by
-;;; might introduce reserved chars (like slashes and colons) that could
+;;; PARSE-URL) before the escaped characters within those components
-;;; blow your parse.
+;;; can be safely decoded. Don't use UNESCAPE on an unparsed URI.
 
-(define (unescape-uri s . maybe-start/end)
+(define (unescape s)
-  (let-optionals maybe-start/end ((start 0)
+  (regexp-fold 
-				  (end (string-length s)))
+   escaped
-    (let* ((esc-seq? (lambda (i) (and (< (+ i 2) end)
+   (lambda (start-search match res)
-				      (char=? (string-ref s i) #\%)
+     (let* ((start-match (match:start match))
-				      (hex-digit? (string-ref s (+ i 1)))
+	    (hexchar-low (string-ref s (+ start-match 2)))
-				      (hex-digit? (string-ref s (+ i 2))))))
+	    (hexchar-high (string-ref s (+ start-match 1)))
-	   (hits (let lp ((i start) (hits 0)) ; count # of esc seqs.
+	    (hex-low (hexchar->int hexchar-low))
-		   (if (< i end)
+	    (hex-high (hexchar->int hexchar-high))
-		       (if (esc-seq? i)
+	    (ascii (+ (* 16 hex-high) hex-low)))
-			   (lp (+ i 3) (+ hits 1))
+       (string-append 
-			   (lp (+ i 1) hits))
+	res 
-		       hits))))
+	(substring s start-search start-match)
-	 
+	(string (ascii->char ascii)))))
-      (if (and (zero? hits) (zero? start) (= end (string-length s)))
+   ""
-	  s
+   s
-	  (let* ((nlen (- (- end start) (* hits 2))) ; the new length
+   (lambda (start-search res)
-						     ; of the
+    (string-append res (substring s start-search (string-length s))))))
-						     ; unescaped
-						     ; string stores
-						     ; the result
-		 (ns (make-string nlen)))
 
-	    (let lp ((i start) (j 0))	; sweep over the string
-	      (if (< j nlen)
-		  (lp (cond 
-		       ((esc-seq? i)	; unescape
-					; escape-sequence
-			(string-set! ns j
-				     (let ((d1 (string-ref s (+ i 1)))
-					   (d2 (string-ref s (+ i 2))))
-				       (ascii->char (+ (* 16 (hexchar->int d1))
-						       (hexchar->int d2)))))
-			(+ i 3))
-		       (else (string-set! ns j (string-ref s i))  
-			     (+ i 1)))
-		      (+ j 1))))
-	    ns)))))
-
-(define hex-digit?
-  (let ((hex-digits (string->char-set "0123456789abcdefABCDEF")))
-    (lambda (c) (char-set-contains? hex-digits c))))
 
 ; make use of the fact that numbers and characters are in order in the ascii table
 (define (hexchar->int c)      
@@ -101,100 +59,47 @@
 		(char->ascii #\a))
 	    10))))
 
-(define int->hexchar
+
-  (let ((table '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-		  #\A #\B #\C #\D #\E #\F)))
+;;; encode a URI:
+;;; replace characters which are reserved or excluded by their escaped representation.
+
+;;; Caution:  
+;;; Each component of a URI may have its own set of characters that are reserved,
+;;; -> differentiate between components by writing specialized procedures
+;;; (see url.scm for examples)
+
+;;; Caution: 
+;;; don't encode an already encoded string; #\% chars would be escaped again.
+
+
+;;; escape occurrences of RegExp regexp in string s
+(define (escape s regexp)
+  (regexp-fold 
+   regexp
+   (lambda (start-search match res)
+     (let* ((start-match (match:start match))
+	   (forbidden-char (string-ref s start-match)))
+       (string-append
+	res
+	(substring s start-search start-match)
+	(ascii->escaped (char->ascii forbidden-char)))))
+   ""
+   s
+   (lambda (start-search res)
+     (string-append res (substring s start-search (string-length s))))))
+
+;;;generate string representing hex-ascii-code for the decimal-ascii-code DEC-INT
+(define (ascii->escaped dec-int)
+  (let* ((hex-int-high (bitwise-and (arithmetic-shift dec-int -4) #xF))
+	(hex-int-low (bitwise-and dec-int #xF)))
+    (string-append 
+     "%" (int->hexstring hex-int-high) (int->hexstring hex-int-low))))
+
+(define int->hexstring
+  (let ((table '#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
+		  "A" "B" "C" "D" "E" "F")))
     (lambda (i) (vector-ref table i))))
-  
 
-;;; Caution:
+   
-;;; All reserved chars (e.g., slash, sharp, colon) get escaped: "=;/#?: "
-;;; So don't apply this proc to chunks of text with syntactically meaningful
-;;; reserved chars (e.g., paths with URI slashes or colons) -- they'll be 
-;;; escaped, and lose their special meaning. E.g. it would be a mistake
-;;; to apply ESCAPE-URI to "//lcs.mit.edu:8001/foo/bar.html" because the
-;;; slashes and colons would be escaped.
 
-(define uri-escaped-chars
-  (char-set-complement 
-   ;; RFC 2396 (URI Generic Syntax) specifies unreserved = alphanum | mark
-   (char-set-union char-set:letter+digit
-                   (string->char-set "-_.!~*'()"))))
-
-;;; Takes a set of chars to escape. This is because we sometimes need to
-;;; escape larger sets of chars for different parts of a URI.
-
-(define (escape-uri s . maybe-escaped-chars)
-  (let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars))
-    (let ((nlen (string-fold
-		 (lambda (c i)
-		   (+ i
-		      (if (char-set-contains? escaped-chars c)
-			  3
-			  1)))
-		 0
-		 s)))    ; new length of escaped string
-      (if (= nlen (string-length s))
-	  s
-	  (let ((ns (make-string nlen))) 
-	    (string-fold
-	     (lambda (c i)     ; replace each occurance of an
-			       ; character to escape with %ff where ff
-			       ; is the ascii-code in hexadecimal
-			       ; notation
-	       (+ i (cond 
-		     ((char-set-contains? escaped-chars c)
-		      (string-set! ns i #\%)
-		      (let* ((d (char->ascii c))
-			     (dhi (bitwise-and (arithmetic-shift d -4) #xF))
-			     (dlo (bitwise-and d #xF)))
-			(string-set! ns (+ i 1)
-				     (int->hexchar dhi))
-			(string-set! ns (+ i 2)
-				     (int->hexchar dlo)))
-		      3)
-		     (else (string-set! ns i c)
-			   1))))
-	     0
-	     s)
-	    ns)))))
-
-;;; Cribbed from scsh's fname.scm
-
-(define (split-uri uri start end)		; Split at /'s (infix grammar).
-  (let split ((i start))			; "" -> ("")
-    (cond
-     ((>= i end) '(""))
-     ((string-index uri #\/ i) =>
-      (lambda (slash)
-	(cons (substring uri i slash)
-	      (split (+ slash 1)))))
-     (else (list (substring uri i end))))))
-
-
-;;; The elements of PLIST must be escaped in case they contain slashes.
-;;; This procedure doesn't escape them for you; you must do that yourself:
-;;;     (uri-path->uri (map escape-uri pathlist))
-
-(define (uri-path->uri plist)
-  (string-join plist "/"))		; Insert slashes between elts of PLIST.
-
-(define (simplify-uri-path p)    
-  (if (null? p)
-      #f				; P must be non-null
-      (let lp ((path-list (cdr p))
-	       (stack (list (car p))))
-	(if (null? path-list)		; we're done
-	    (reverse stack)
-	    (cond
-	     ((string=? (car path-list) "..") ; back up
-					; neither the empty path nor root
-	      (if (not (or (null? stack) (string=? (car stack) "")))  
-		  (lp (cdr path-list) (cdr stack))
-		  #f))
-	     ((string=? (car path-list) ".") ; leave this
-	      (lp (cdr path-list) stack))
-	     ((string=? (car path-list) "") ; back to root
-	      (lp (cdr path-list) '("")))
-	     (else			; usual segment
-	      (lp (cdr path-list) (cons (car path-list) stack))))))))

scheme/lib/url.scm

@@ -1,163 +1,399 @@
-;;; URL parsing and unparsing -*- Scheme -*-
+;;; HTTP 1.1 Request-URI parsing and unparsing -*- Scheme -*-
 
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 1995 by Olin Shivers.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
-;;; I'm only implementing HTTP URL's right now.
-
 ;;; References:
-;;; - http://www.w3.org/Addressing/rfc1738.txt
+;;; RFC 2616 Hypertext Transfer Protocol -- HTTP/1.1
-;;;   Original RFC
+;;; RFC 2396 Uniform Resource Identifiers (URI): Generic Syntax
-;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/Overview.html
+;;;
-;;;   General Web page of URI pointers.
+;;; RFC 2616 adopts definitions of regexps from RFC 2396
+;;; (see copy of Appendix A of RFC 2396 below)
 
 
-;;; Unresolved issues:
+;;; Note: there are 2 Problems in RFC 2616 concerning URIS:
-;;; - The server parser shouldn't substitute default values --
-;;;   that should happen in a separate step.
 
-;;; The steps in hacking a URL are:
+;;; Problem 1:
-;;; - Take the UID, parse it, and resolve it with the context UID, if any.
+;;; RFC 2616 is ambiguous in defining Request_URIS:
-;;; - Consult the UID's <scheme>. Pick the appropriate URL parser and parse.
+;;;
+;;; section 5.1.2 states:
+;;; HTTP 1.1 Request-URIS are of the form
+;;; Request-URI    = "*" | absoluteURI | abs_path | authority
+;;;
+;;; whilst section 3.2.2 defines the 'http_URL'
+;;; http_URL = "http://" host [ ":" port ] [ abs_path [ "?" query ]]
+;;;
+;;; Solution to Problem 1:
+;;; Since allowing for general absoluteURIs doesn't make too much sense
+;;; we implement Request_URIs of the form
+;;; Request-URI    = ( http_URL | abs_path) ["#" fragment]
+;;; where http_URL is a only a subset of absoluteURI
 
 
-;;; Server strings: //<user>:<password>@<host>:<port>/
+;;; Problem 2: 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; according to RFC 2616, section 5.1.2, the Request-URI may only
-;;; A SERVER record describes path-prefixes of the form
+;;; have a [? query] part if it's an absoluteURI; on the other hand
-;;;     //<user>:<password>@<host>:<port>/
+;;; only requests being made to proxies are supposed to use
-;;; These are frequently used as the initial prefix of URL's describing
+;;; absoluteURIs; abs_path is the normal case. So this must be a mistake.
-;;; Internet resources.
+;;; See also http://skrb.org/ietf/http_errata.html#uriquery
-
+;;;
-(define-record-type server :server		; Each slot is a decoded string or #f.
+;;; Solution to Problem 2:
-  (make-server user password host port)
+;;, we implement Request_URIs of the form
-  server?
+;;; Request-URI    = ( http_URL | abs_path ["?" query] ) ["#" fragment]
-  (user server-user)
-  (password server-password)
-  (host server-host)
-  (port server-port))
-
-;;; Parse a URI path (a list representing a path, not a string!) into
-;;; a server record. Default values are taken from the server
-;;; record DEFAULT except for the host. Returns a server record if
-;;; it wins. CADDR drops the server portion of the path. In fact,
-;;; fatal-syntax-error is called, if the path doesn't start with '//'.
-
-					; 
-(define (parse-server path default)
-  (if (and (pair? path)			; The thing better begin
-	   (string=? (car path) "")	; with // (i.e., have two
-	   (pair? (cdr path))		; initial "" elements).
-	   (string=? (cadr path) ""))
-	 
-      (let* ((uhs (caddr path))		; Server string.
-	     (uhs-len (string-length uhs))
-	     (at (string-index uhs #\@)) ; Usr:passwd at-sign, if any.
-	       
-	     (colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon,
-	     (colon1 (and colon1 (< colon1 at) colon1))	; if any.
-
-	     (colon2 (string-index uhs #\: (or at 0))))	; Host:port colon, if any.
-	(make-server (if at
-			 (unescape-uri uhs 0 (or colon1 at))
-			 (server-user default))
-		     (if colon1
-			 (unescape-uri uhs (+ colon1 1) at)
-			 (server-password default))
-		     (unescape-uri uhs (if at (+ at 1) 0)
-				   (or colon2 uhs-len))
-		     (if colon2
-			 (unescape-uri uhs (+ colon2 1) uhs-len)
-			 (server-port default))))
-
-      (fatal-syntax-error "URL must begin with //..." path)))
-
-;;; Unparser
-
-(define server-escaped-chars
-  (char-set-union uri-escaped-chars	; @ and : are also special
-		  (string->char-set "@:"))) ; in UH strings.
-
-(define (server->string uh)
-  (let* ((us (server-user uh))
-	 (pw (server-password uh))
-	 (ho (server-host uh))
-	 (po (server-port uh))
-
-	 ;; Encode before assembly in case pieces contain colons or at-signs.
-	 (e (lambda (s) (escape-uri s server-escaped-chars)))
-
-	 (user/passwd (if us
-			  `(,(e us) . ,(if pw `(":" ,(e pw) "@") '("@")))
-			  '()))
-	 (host/port   (if ho
-			  `(,(e ho) . ,(if po `(":" ,(e po)) '()))
-			  '())))
-
-    (apply string-append (append user/passwd host/port))))
 
 
-;;; HTTP URL parsing
+;;; Note: we don't have to support Request-URIS of the form "*" or
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; authority, because these are not used with the any of the methods
+;;; HEAD, GET and POST, which are the only methods we implement so
+;;; far.
 
-;;; The PATH slot of this record is the URL's path split at slashes,
+
-;;; e.g., "foo/bar//baz/" => ("foo" "bar" "" "baz" "")
+;;; Here we depart from the RFCs:
-;;; These elements are in raw, unescaped format. To convert back to
+;;; RFC 2616 and 1945 disallow a #fragment-suffix of the Request-URI.
-;;; a string, use (uri-path->uri (map escape-uri pathlist)).
+;;; For compatibility with buggy clients we _do_ allow for it.
+;;; (Apache does so, too).
+
+
+
+;;; RexExps for Request-URIs as scsh SREs
+;;; stick to RFC terminology throughout
+;;; (see copy of Appendix A of RFC 2396 below)
+;;;
+;;; we implement Request_URIs of the form
+;;; Request-URI    = ( http_URL | abs_path ["?" query] ) ["#" fragment]
+
+(define digit (rx numeric))
+
+(define alpha (rx alphabetic))
+
+(define alphanum (rx alphanumeric))
+
+(define hex (rx hex-digit))
+
+(define escaped (rx (: "%" ,hex ,hex)))
+
+(define mark (rx ( "-_.!~*'()")))
+
+(define unreserved (rx (~ (~ (| ,alphanum ,mark)))))
+
+(define reserved (rx ( ";/?:@&=+$,")))
+
+(define uric (rx (| ,reserved ,unreserved ,escaped)))
+
+(define fragment (rx (* ,uric)))
+
+(define query (rx (* ,uric)))
+
+(define pchar-charset (rx ( ":@&=+$,")))
+
+(define pchar (rx (| ,unreserved ,escaped ,pchar-charset)))
+
+(define param (rx (* ,pchar)))
+
+(define segment (rx (:
+		     (* ,pchar)
+		     (* (: ";" ,param)))))
+
+(define path-segments (rx (:
+			   ,segment 
+			   (* (: "/" ,segment)))))
+
+(define abs_path (rx (: 
+		      "/" 
+		      ,path-segments)))
+
+
+(define port (rx (* ,digit)))
+
+(define IPv4address (rx (+ ,digit) "." (+ ,digit) "." (+ ,digit) "." (+ ,digit)))
+
+(define toplabel (rx (:
+		      (|
+		       ,alpha
+		       (: 
+		       ,alpha 
+		       (* (| ,alphanum "-"))
+		       ,alphanum)))))
+
+(define domainlabel (rx (:
+			 (|
+			  ,alphanum
+			  (: ,alphanum 
+			     (* (| ,alphanum "-"))
+			     ,alphanum)))))
+
+(define hostname (rx (:
+		      (* (: ,domainlabel "."))
+		      ,toplabel 
+		      (? "."))))
+
+(define host (rx (| ,hostname ,IPv4address)))
+
+(define http_URL (rx (:
+		      "http://" 
+		      (submatch ,host)
+		      (? 
+		       (: ":" (submatch ,port)))
+		      (? 
+		       (: (submatch ,abs_path)
+			  (? 
+			   (: "?" (submatch ,query))))))))
+
+(define http_URL_with_frag (rx (: bos
+				  ,@http_URL 
+				  (? (: "#" ,fragment))
+				  eos)))
+
+
+(define abs_path_with_frag (rx (: bos 
+				(submatch ,abs_path) 
+				(? (: "?" (submatch ,query)))
+				(? (: "#" ,fragment))
+				eos)))
+
+(define Request-URI (rx (| ,@http_URL_with_frag ,@abs_path_with_frag)))
+
+
+
+;;; parse a HTTP 1.1 Request_URI
+;;; 
+;;; return matches of regexps host, port, abs_path, query;
+;;;
+;;; If request-uri is a relative URI, host and port are #f;
+;;; port and query are also #f if they are not given.
+;;; If there's no abs_path given, or abs_path is "/", path is the empty list;
+;;; otherwise it is a list containing the path's segments.
+;;;
+
+;;; Caution: parse-url doesn't unescape anything yet!
+
+(define (parse-url request-uri)
+   (cond 
+
+    ((regexp-search abs_path_with_frag request-uri)
+     => (lambda (match)
+	  (let ((path (split-abs-path (match:substring match 1)))
+		(query (match:substring match 2)))
+	    (values #f #f path query))))
+
+    ((regexp-search http_URL_with_frag request-uri)
+     =>(lambda (match)
+	 (let ((host (match:substring match 1))
+	       (port (match:substring match 2))
+	       (path (split-abs-path (match:substring match 3)))
+	       (query (match:substring match 4)))
+	   (values host port path query))))
+
+    (else
+     (fatal-syntax-error "Request-URI syntactically faulty"))))
+ 
+  
+;;; split the string abs-path at slashes, return list of 'segments' (see RegExp definition above).
+;;;
+;;; SPLIT-PATH assumes abs-path if either #f or matches the RegExp abs_path, 
+;;; no checks are done.
+;;;
+;;; Remark: abs_path allows for strings containing several consecutive slashes;
+;;; SPLIT-ABS-PATH treats them as one slash.
+;;; (e.g., "/foo///bar//baz" => ("foo" "bar" "baz")) 
+;;; 
+;;; Note: we have to differentiate between paths with trailing
+;;; slash(es) and paths without and hand that information over
+;;; to the request handler. (See
+;;; http://httpd.apache.org/docs-2.0/misc/rewriteguide.html -> 
+;;;"Trailing Slash problem" for the reasons.) 
+;;; If there is one or more trailing slash(es) the last element of the
+;;; returned list will be an empty string.  
+;;; (e.g., "/foo///bar//baz//" => ("foo" "bar" "baz" ""))
+
+
+(define (split-abs-path abs-path)
+
+  (if abs-path 
+
+      (let* ((trailing-slash (char=? #\/ (string-ref abs-path (- (string-length abs-path) 1))))
+	    (last-element (if trailing-slash '("") '())))
+	(regexp-fold-right 
+	 (rx (+ (~ ("/"))))
+	 (lambda (match i res)
+	   (cons (match:substring match 0) res))
+	 last-element
+	 abs-path))
+
+	'()))
+
+
+;;; record type HTTP-URL for Request_URIs
+;;; 
+;;; The HOST slot is a non-empty-string or #f.
+;;;
+;;; The PORT slot is an integer or #f.
+;;;
+;;; The PATH slot is a list of strings containing the Request_URI's
+;;; path split at slashes and unescaped. If the Request_URI's path
+;;; ends with a slash, an empty string is inserted as the last element
+;;; of the list.
+;;; (e.g., "/foo///bar//baz" => ("foo" "bar" "baz")) 
+;;; (e.g., "/foo///bar//baz//" => ("foo" "bar" "baz" "")) 
+;;;
+;;; The QUERY slot is an non-empty-string, still in its escaped
+;;; representation, or #f.
+
+;;; Caution: the path slot of a http-url record has already been
+;;; UNESCAPED; don't unescape it a second time!
+;;; The query slot is still in its escaped representation.
 
 (define-record-type http-url :http-url
-  (make-http-url server path search fragment-identifier)
+  (make-http-url host port path query)
   http-url?
-  (server http-url-server)		; Initial //anonymous@clark.lcs.mit.edu:80/
+  (host http-url-host)
-  (path http-url-path)			; Rest of path, split at slashes & decoded.
+  (port http-url-port)		
-  (search http-url-search)
+  (path http-url-path)
-  (fragment-identifier http-url-fragment-identifier))
+  (query http-url-query))
 
-;;; The URI parser (parse-uri in uri.scm) maps a string to four parts:
+;;; Is http-url of the form http_URL, i.e. absolute?
-;;; <scheme> : <path> ? <search> # <frag-id> <scheme>, <search>, and
+(define (absolute-url? http-url)
-;;; <frag-id> are strings; <path> is a non-empty string list -- the
+  (http-url-host http-url))
-;;; URI's path split at slashes. Optional parts of the URI, when
-;;; missing, are specified as #f. If <scheme> is "http", then the
-;;; other three parts can be passed to PARSE-HTTP-URL, which parses
-;;; them into a HTTP-URL record. All strings come back from the URI
-;;; parser encoded. SEARCH and FRAG-ID are left that way; this parser
-;;; decodes the path elements.
-;;;
-;;; Returns a HTTP-URL record, if possible. Otherwise
-;;; FATAL-SYNTAX-ERROR is called.
 
-(define (parse-http-url path search frag-id)
+;;; parse a HTTP 1.1. Request_URI into a http-url record
-  (let ((uh (parse-server path default-http-server)))
-    (if (or (server-user uh) (server-password uh))
-	(fatal-syntax-error
-	 "HTTP URL's may not specify a user or password field" path))
 
-    (make-http-url uh (map unescape-uri (cdddr path)) search frag-id)))
+(define (url-string->http-url uri-string)
+  (receive (host port path query)
+	   (parse-url uri-string)
+	   (let ((portnumber (and port (string->number port)))
+		 (unescaped-path (map unescape path)))
+	     (make-http-url host portnumber unescaped-path query))))
+  
 
-(define (parse-http-url-string string)
+;;; Unparse a http-url record into its corresponding Request_URI
-  (call-with-values
-   (lambda () (parse-uri string))
-   (lambda (scheme path search frag-id)
-     (if (string=? scheme "http")
-	 (parse-http-url path search frag-id)
-	 (fatal-syntax-error "not an HTTP URL" path)))))
 
-;;; Default http port is 80.
+;;; The following holds (apart from multiple slashes in the path,
-(define default-http-server (make-server #f #f #f "80"))
+;;; which are removed by url-string->http-url):
+;;; (http-url->url-string (url-string->http-url <request-uri-string>)) == <request-uri-string>
 
+(define (http-url->url-string http-url)
 
-;;; Unparse.
+  (let* ((host (http-url-host http-url))
+	(scheme-and-host-string 
+	 (if host
+	     (string-append "http://" host)
+	     ""))
 
-(define (http-url->string url)
+	(port (http-url-port http-url))
-  (string-append "http://"
+	(port-string 
-		 (server->string (http-url-server url))
+	 (if port
-		 "/"
+	     (string-append ":" (number->string port))
-		 (uri-path->uri (map escape-uri (http-url-path url)))
+	     ""))
-		 (cond ((http-url-search url) =>
+
-			(lambda (s) (string-append "?" s)))
+	(path (http-url-path http-url))
-		       (else ""))
+	(path-string 
-		 (cond ((http-url-fragment-identifier url) =>
+	 (fold-right
-			(lambda (fi) (string-append "#" fi)))
+	  (lambda (segment res)
-		       (else ""))))
+	    (string-append "/" (escape-segment segment) res))
+	  ""
+	  path))
+
+	(query (http-url-query http-url))
+	(query-string (if query
+			(string-append "?" query)
+			"")))
+
+    (string-append scheme-and-host-string port-string path-string query-string)))
+
+;;; Unparse the http-url-path field of an http-url record into its
+;;; corresponding part of the Request_URI 
+
+(define (http-url-path->path-string http-url-path)
+  (fold-right
+   (lambda (segment res)
+     (string-append "/" (escape-segment segment) res))
+   ""
+   http-url-path))
+
+;;; decoding and encoding Request-URIs:
+
+;;; to decode Request-URIs use UNESCAPE from uri.scm
+
+;;; encode Request-URIs:
+;;; Each component of a URI may have its own set of characters that are reserved,
+;;; -> differentiate between components.
+
+;;; not allowed within component 'segment' in 'abs_path'
+(define segment-reserved-and-excluded (rx (~ ,unreserved ,pchar-charset (";"))))
+
+;;; not allowed within component 'query' 
+(define query-reserved-and-excluded (rx (~ ,unreserved ,reserved )))
+
+;;; encode 'abs_path' portion of a URI:
+;;; use SPLIT-PATH to split abs_path into its segments,
+;;; then apply ESCAPE-SEGMENT to the segments. 
+(define (escape-segment segment)
+  (escape segment segment-reserved-and-excluded))
+
+;;; encode 'query' portion of a URI
+(define (escape-query query)
+  (escape query query-reserved-and-excluded))
+
+;;; encode something we don't know: escape all but the unreserved characters.
+(define (escape-not-unreserved-chars something)
+  (escape something (rx (~ ,unreserved))))
+
+;; Appendix A of RFC 2396
+;;
+;A. Collected BNF for URI
+
+;      URI-reference = [ absoluteURI | relativeURI ] [ "#" fragment ]
+;      absoluteURI   = scheme ":" ( hier_part | opaque_part )
+;      relativeURI   = ( net_path | abs_path | rel_path ) [ "?" query ]
+;      hier_part     = ( net_path | abs_path ) [ "?" query ]
+;      opaque_part   = uric_no_slash *uric
+;      uric_no_slash = unreserved | escaped | ";" | "?" | ":" | "@" |
+;                      "&" | "=" | "+" | "$" | ","
+;      net_path      = "//" authority [ abs_path ]
+;      abs_path      = "/"  path_segments
+;      rel_path      = rel_segment [ abs_path ]
+;      rel_segment   = 1*( unreserved | escaped |
+;                          ";" | "@" | "&" | "=" | "+" | "$" | "," )
+;      scheme        = alpha *( alpha | digit | "+" | "-" | "." )
+;      authority     = server | reg_name
+;      reg_name      = 1*( unreserved | escaped | "$" | "," |
+;                          ";" | ":" | "@" | "&" | "=" | "+" )
+;      server        = [ [ userinfo "@" ] hostport ]
+;      userinfo      = *( unreserved | escaped |
+;                         ";" | ":" | "&" | "=" | "+" | "$" | "," )
+;      hostport      = host [ ":" port ]
+;      host          = hostname | IPv4address
+;      hostname      = *( domainlabel "." ) toplabel [ "." ]
+;      domainlabel   = alphanum | alphanum *( alphanum | "-" ) alphanum
+;      toplabel      = alpha | alpha *( alphanum | "-" ) alphanum
+;      IPv4address   = 1*digit "." 1*digit "." 1*digit "." 1*digit
+;      port          = *digit
+;      path          = [ abs_path | opaque_part ]
+;      path_segments = segment *( "/" segment )
+;      segment       = *pchar *( ";" param )
+;      param         = *pchar
+;      pchar         = unreserved | escaped |
+;                      ":" | "@" | "&" | "=" | "+" | "$" | ","
+;      query         = *uric
+;      fragment      = *uric
+;      uric          = reserved | unreserved | escaped
+;      reserved      = ";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" |
+;                      "$" | ","
+;      unreserved    = alphanum | mark
+;      mark          = "-" | "_" | "." | "!" | "~" | "*" | "'" |
+;                      "(" | ")"
+;      escaped       = "%" hex hex
+;      hex           = digit | "A" | "B" | "C" | "D" | "E" | "F" |
+;                              "a" | "b" | "c" | "d" | "e" | "f"
+;      alphanum      = alpha | digit
+;      alpha         = lowalpha | upalpha
+;      lowalpha = "a" | "b" | "c" | "d" | "e" | "f" | "g" | "h" | "i" |
+;                 "j" | "k" | "l" | "m" | "n" | "o" | "p" | "q" | "r" |
+;                 "s" | "t" | "u" | "v" | "w" | "x" | "y" | "z"
+;      upalpha  = "A" | "B" | "C" | "D" | "E" | "F" | "G" | "H" | "I" |
+;                 "J" | "K" | "L" | "M" | "N" | "O" | "P" | "Q" | "R" |
+;                 "S" | "T" | "U" | "V" | "W" | "X" | "Y" | "Z"
+;      digit    = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" |
+;                 "8" | "9"

scheme/packages.scm

@@ -3,10 +3,6 @@
 
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
-;;; Copyright (c) 1996-2002 by Mike Sperber.
-;;; Copyright (c) 2000-2002 by Martin Gasbichler.
-;;; Copyright (c) 1998-2001 by Eric Marsden.
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
@@ -19,6 +15,7 @@
 
 (define-interface htmlout-interface
   (export emit-tag
+	  emit-empty-tag
 	  emit-close-tag
 
 	  emit-p
@@ -29,7 +26,10 @@
 	  with-tag*
 
 	  escape-html
-	  emit-text))
+	  emit-text
+
+	  emit-prolog
+	  xmlnsdecl-attr))
 
 (define-interface smtp-interface
   (export smtp-send-mail
@@ -49,37 +49,23 @@
 	  rfc822-time->string))
 
 (define-interface uri-interface 
-  (export parse-uri
+  (export unescape
-	  uri-escaped-chars
+	  escape))
-	  unescape-uri
+ 
-	  escape-uri
-	  split-uri
-	  uri-path->uri
-	  simplify-uri-path))
-
 (define-interface url-interface
-  (export server?
+  (export escape-not-unreserved-chars
-	  make-server
+	  escaped
-
-	  server-user
-	  server-password
-	  server-host
-	  server-port
-
-	  parse-server
-	  server->string
 
 	  http-url?
-	  make-http-url
+	  http-url-host
-
+	  http-url-port
-	  http-url-server
 	  http-url-path
-	  http-url-search
+	  http-url-query
-	  http-url-fragment-identifier
 
-	  parse-http-url
+	  absolute-url?
-	  parse-http-url-string
+	  url-string->http-url
-	  http-url->string))
+	  http-url->url-string
+	  http-url-path->path-string))
 
 (define-interface ftp-library-interface
   (export copy-port->port-binary
@@ -341,7 +327,8 @@
 	  version->string))
 
 (define-interface httpd-responses-interface
-  (export make-response response?
+  (export http-version 
+	  make-response response?
 	  response-code
 	  response-message
 	  response-seconds
@@ -358,6 +345,7 @@
 	  make-writer-body writer-body?
 	  make-reader-writer-body reader-writer-body?
 	  make-redirect-body redirect-body? redirect-body-location
+	  no-body? 
 	  display-http-body
 
 	  status-code?
@@ -370,6 +358,10 @@
 	  make-error-response
 	  make-redirect-response))
 
+(define-interface httpd-handler-lib-interface
+  (export get-socket-host-string
+	  read-message-body))
+
 (define-interface httpd-basic-handlers-interface
   (export make-predicate-handler
 	  make-path-predicate-handler
@@ -469,19 +461,14 @@
 
 (define-structure uri uri-interface
   (open scheme-with-scsh
-	(subset srfi-13 (string-index string-index-right string-fold string-join))
-	let-opt
-	receiving
 	ascii
-	bitwise
+	bitwise)
-	field-reader-package)
   (files (lib uri)))
 
 (define-structure url url-interface
   (open scheme-with-scsh
 	define-record-types
-	receiving
+	(subset srfi-1 (fold-right))
-	(subset srfi-13 (string-index))
 	uri
 	httpd-errors)
   (files (lib url)))
@@ -599,7 +586,7 @@
   (open scheme-with-scsh
 	format-net
 	sigevents
-	(subset srfi-13 (string-join))
+	(subset srfi-13 (string-join string-skip string-trim-both)) 
 	dns
 	let-opt				; :optional
 	locks
@@ -642,7 +629,6 @@
 	rfc822
 	handle				; ignore-errors
 	conditions			; condition-stuff
-	uri
 	url
 	format-net
 	rate-limit			; rate-limiting stuff
@@ -660,6 +646,7 @@
 	httpd-logging
 	httpd-requests
 	httpd-responses
+	httpd-handler-lib
 
 	sunet-version
 	)
@@ -696,8 +683,7 @@
 	i/o				; make-null-output-port
 	locks
 	receiving
-	uri				; uri-path->uri
+	url				; http-url-path, http-url-path->path-string
-	url				; http-url-path
 	httpd-requests			; request record
 	httpd-responses
 	formats
@@ -721,6 +707,8 @@
 (define-structure httpd-responses httpd-responses-interface
   (open scheme
 	(subset scsh (format-date write-string time date))
+	url
+	htmlout 
 	syslog
 	define-record-types
 	finite-types
@@ -730,12 +718,26 @@
 	httpd-read-options)
   (files (httpd response)))
 
+(define-structure httpd-handler-lib httpd-handler-lib-interface
+  (open scheme-with-scsh
+	crlf-io	; read-crlf-line
+	rfc822 ;read-rfc822-headers
+	format-net ;format-internet-host-address
+	(subset srfi-13 (string-trim-both string-trim string-prefix? string-reverse string-contains string-take))
+	handle-fatal-error
+	sunet-utilities ;get-header
+	httpd-requests
+	httpd-responses
+	httpd-errors)
+  (files (httpd handler-lib)))
+
 (define-structure httpd-basic-handlers httpd-basic-handlers-interface
   (open scheme-with-scsh
 	rfc822
 	httpd-requests			; REQUEST record type, v0.9-request
 	(subset srfi-1 (fold-right))
 	(subset srfi-13 (string-trim string-prefix-ci?))
+	sunet-utilities
 	httpd-responses
 	httpd-errors
 	)
@@ -748,6 +750,7 @@
 	httpd-requests
 	httpd-responses
 	httpd-errors
+	httpd-handler-lib
 	httpd-basic-handlers
 	httpd-read-options
 	url
@@ -768,7 +771,7 @@
 	httpd-requests			; v0.9-request
 	httpd-responses
 	httpd-logging			; http-log
-	uri				; UNESCAPE-URI
+	httpd-handler-lib
 	htmlout				; Formatted HTML output
 	pp
 	(subset srfi-13 (string-skip))
@@ -777,7 +780,8 @@
 	handle				; IGNORE-ERROR
 	parse-html-forms		; PARSE-HTML-FORM-QUERY
 	threads				; SLEEP
-	sunet-utilities			; GET-HEADER
+	sunet-utilities
+	handle-fatal-error
 	)
   (files (httpd seval)))
 
@@ -815,7 +819,7 @@
 (define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
   (open	scheme-with-scsh
 	(subset srfi-1 (alist-delete))
-	(subset srfi-13 (string-prefix? string-index string-trim substring/shared))
+	(subset srfi-13 (string-prefix? string-index string-trim substring/shared string-join))
 	rfc822
 	crlf-io			; WRITE-CRLF
 	uri
@@ -825,6 +829,7 @@
 	httpd-responses
 	httpd-basic-handlers	; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
 	httpd-errors		; HTTP-ERROR
+	httpd-handler-lib
 	httpd-file-directory-handlers		; dot-dot-check, copy-inport->outport
 	sunet-version
 	formats

start-extended-web-server

@@ -111,11 +111,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
        (else
 	(error "Internal error, option not found" option alist))))
 
-    (define (become-nobody-if-root)
-      (cond ((zero? (user-uid))
-	     (set-gid (->gid "nobody"))
-	     (set-uid (->uid "nobody")))))
-
     (define (main args)
       (with-cwd
 	  (file-name-directory (car args))
@@ -126,6 +121,9 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
                      (log-file-name	. "/tmp/httpd.log")
                      (requests	. 5)))
                  (options (make-options-from-args (cdr args) default-options)))
+	  (cond ((zero? (user-uid))
+		 (set-gid (->gid "nobody"))
+		 (set-uid (->uid "nobody"))))
 
 	  (format #t "Going to run Webserver with:
  htdocs-dir:    ~a
@@ -147,15 +145,15 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
 		  with-simultaneous-requests	(lookup-option options 'requests)
 		  with-syslog?			#t
 		  with-log-file			(lookup-option options 'log-file-name)
-                  with-post-bind-thunk          become-nobody-if-root
 		  with-request-handler 
 		  (alist-path-dispatcher
-		   (list (cons "seval" seval-handler) 
+		   (list (cons "h" (home-dir-handler "public_html"))
+			 (cons "seval" seval-handler) 
 			 ;; You may want to adapt this to your site.
 			 ;; call like http://localhost:8080/man/man?ssh(1)
 			 (cons "man" (rman-handler 'man
 						   'nroff
-						   "/usr/X11R6/bin/rman"
+						   "/usr/bin/rman"
 						   "/usr/bin/zcat"
 						   #f "man?%s(%s)" 
 						   "Generated by rman-gateway"))
@@ -165,9 +163,8 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
 						    "Generated by info-gateway"))
 			 (cons "cgi-bin" (cgi-handler 
 					  (lookup-option options 'cgi-bin-dir))))
-                   (tilde-home-dir-handler "public_html"
+		   (rooted-file-or-directory-handler 
-                                           (rooted-file-or-directory-handler 
+		    (lookup-option options 'htdocs-dir))))))))
-                                            (lookup-option options htdocs-dir)))))))))
       ))
 
 ;; EOF

start-surflet-server

@@ -11,8 +11,10 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 	httpd-make-options
 	httpd-basic-handlers
 	httpd-file-directory-handlers
-	httpd-cgi-handlers
+;	cgi-server
-	httpd-seval-handlers
+;	seval-handler
+;	rman-gateway
+;	info-gateway
 	surflet-handler
 	surflet-handler/options
 	let-opt
@@ -27,7 +29,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
       (format #f 
 "Usage: start-surflet-server 
              [-h DIR | --htdocs-dir=DIR] [-s DIR | --surflet-dir=DIR]
-             [--cgi-bin-dir=DIR]
              [-i DIR | --images-dir=DIR] [-p NUM | --port=NUM] 
              [-l FILE | --log-file-name=FILE] [-r NUM | --requests=NUM]
              [--help]
@@ -35,14 +36,14 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
  with
  htdocs-dir     directory of html files (default: root/htdocs)
  surflet-dir    directory of SUrflet files  (default: root/surflets)
- cgi-bin-dir    directory of cgi files  (default: root/cgi-bin)
  images-dir     directory of images files (default: root/img)
- port           port server is listening to (default: 8080)
+ port           port server is listening to (default: 8008)
  log-file-name  directory where to store the logfile in CLF
                  (default: /tmp/httpd.log)
  requests       maximal amount of simultaneous requests (default 5)
  --help         show this help
-"))
+
+ NOTE: This is the SUrflet-server. It does not support cgi-bin.~%"))
 
     (define (display-usage)
       (display (usage) (current-error-port))
@@ -82,9 +83,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 	      (surflet-dir-option
 	       (option '(#\s "surflet-dir") #t #f
 		       (absolute-file-option-proc 'surflet-dir)))
-	      (cgi-bin-dir-option
-	       (option '(#\c "cgi-bin-dir") #t #f
-		       (absolute-file-option-proc 'cgi-bin-dir)))
 	      (images-dir-option
 	       (option '(#\i "images-dir") #t #f
 		       (absolute-file-option-proc 'images-dir)))
@@ -103,7 +101,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 			 (display-usage)))))
 	  (args-fold arg-list
 		     (list htdocs-dir-option surflet-dir-option
-                           cgi-bin-dir-option
 			   images-dir-option port-option
 			   log-file-name-option requests-option
 			   help-option)
@@ -131,38 +128,34 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 	  (main `(main ,@(car args)))
 	  (main '(main))))
     
-    (define (become-nobody-if-root)
-      (cond ((zero? (user-uid))
-	     (set-gid (->gid "nobody"))
-	     (set-uid (->uid "nobody")))))
-
     (define (main args)
       (with-cwd 
 	  (file-name-directory (car args))
 	(let* ((default-options
                  `((htdocs-dir	. ,(absolute-file-name "root/htdocs"))
                    (surflet-dir	. ,(absolute-file-name "root/surflets"))
-                   (cgi-bin-dir	. ,(absolute-file-name "root/cgi-bin"))
                    (images-dir	. ,(absolute-file-name "root/img"))
-                   (port		. 8080)
+                   (port		. 8008)
                    (log-file-name	. "/tmp/httpd.log")
                    (requests	. 5)))
                (options (make-options-from-args (cdr args) default-options)))
+	 (cond ((zero? (user-uid))
+		(set-gid (->gid "nobody"))
+		(set-uid (->uid "nobody"))))
 
 	 (format #t "Going to run SUrflet server with:
  htdocs-dir:    ~a
  surflet-dir:   ~a
- cgi-bin-dir:   ~a
  images-dir:    ~a
  port:          ~a
  log-file-name: ~a
  a maximum of ~a simultaneous requests, syslogging activated, 
  and home-dir-handler (public_html) activated.
 
+ NOTE: This is the SUrflet server. It does not support cgi.
 "
 		 (lookup-option options 'htdocs-dir)
 		 (lookup-option options 'surflet-dir)
-		  (lookup-option options 'cgi-bin-dir)
 		 (lookup-option options 'images-dir)
 		 (lookup-option options 'port)
 		 (lookup-option options 'log-file-name)
@@ -175,7 +168,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 	   with-simultaneous-requests	(lookup-option options 'requests)
 	   with-syslog?			#t
 	   with-log-file		(lookup-option options 'log-file-name)
-           with-post-bind-thunk          become-nobody-if-root
 	   ;; The following settings are made to avoid dns lookups.
 	   with-reported-port		(lookup-option options 'port)
 	   with-fqdn			"localhost"
@@ -183,8 +175,7 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 	   with-request-handler 
 	   (alist-path-dispatcher
 	    (list
-             (cons "cgi-bin" (cgi-handler (lookup-option options 'cgi-bin-dir)))
+	     (cons "h"		(home-dir-handler "public_html"))
-             (cons "seval" seval-handler)
 	     (cons "source"	(rooted-file-or-directory-handler 
 				 (lookup-option options 'surflet-dir)
 				 (with-file-name->content-type
@@ -198,9 +189,8 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
 	     (cons "surflet"	(surflet-handler 
 				 (with-surflet-path 
 				  (lookup-option options 'surflet-dir)))))
-            (tilde-home-dir-handler "public_html"
+	     (rooted-file-or-directory-handler 
-                                    (rooted-file-or-directory-handler
+				(lookup-option options 'htdocs-dir))))))))
-                                     (lookup-option options 'htdocs-dir)))))))))
     ))
 ;; EOF
 

web-server/root/htdocs/index.html

@@ -9,24 +9,19 @@
     <ul>
       <li><a href="/sunet-manual/index.html">SUnet release manual</a></li>
       <li><a href="/cgi-bin/comments.sh">A small CGI script</a></li>
-      <li><a href="/index-surflet.html">SUrflets homepage</a> 
+      <li><a href="/index-surflet.html">SUrflets homepage</a></li>
-        (<code>start-surflet-server</code> only)</li>
       <li><a href="seval.html">Computing Scheme Forms
 	  Interactively</a></li>
       <li><a href="files/text.txt">Text file</a></li>
       <li><a href="files">Directory</a></li>
       <li><a href="files/zipped.gz">Compressed File</a></li>
       <li><a href="index.html">This file</a></li>
-      <li><a href="man/man?man(1)">man ls</a> 
-        (<code>start-extended-web-server</code> only)</li>
-      <li><a href="info/info?(info.info)Top">Info page for Info</a> 
-        (<code>start-extended-web-server</code> only)</li></li>
     </ul>
     <br>
     <hr>
     <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
     <!-- hhmts start -->
-Last modified: Mon May 17 10:13:07 MST 2004
+Last modified: Wed Apr 23 09:25:58 MST 2003
 <!-- hhmts end -->
   </body>
 </html>

web-server/root/surflets/add-html.scm

@@ -28,7 +28,7 @@
 			 (p (url "/" "Return to main menu") (br)
 			    (url "add-html.scm" "Start new calculation."))))))))
 	(let* ((bindings (form-query-list
-			  (http-url-search (surflet-request-url result))))
+			  (http-url-query (surflet-request-url result))))
 	       (number (string->number 
 			(extract-single-binding "number" bindings))))
 	  (if number
@@ -53,7 +53,7 @@
 			    (a (@ (href "javascript:history.go(-2)")) "New calculation (same session)")(br)
 			    (a (@ (href ,new-url)) "Close this session")))))))
 	;; How to clear session data and go to another HTML page:
-	(send-error (status-code moved-temp) req 
+	(send-error (status-code temp-redirect) req 
 		    "/" "/")
 	))
 ;	))

web-server/root/surflets/add-raw.scm

@@ -2,7 +2,7 @@
   (open	surflet-requests		; SURFLET-REQUEST-url
 	httpd-responses			; MAKE-RESPONSE
 	parse-html-forms		; PARSE-HTML-FORM-QUERY
-	url				; HTTP-url-SEARCH
+	url				; http-url-query
 	srfi-1				; FILTER
 	surflet-handler/surflets	; SEND/SUSPEND, SEND/FINISH
 	surflet-handler/primitives	; MAKE-SURFLET-RESPONSE
@@ -79,7 +79,7 @@
       (let* ((title (if (pair? maybe-title) (car maybe-title) #f))
 	     (result (send/suspend (make-get-number-page input-text title)))
 	     (bindings (parse-html-form-query
-			(http-url-search (surflet-request-url result))))
+			(http-url-query (surflet-request-url result))))
 	     (number (string->number 
 		      (extract-single-binding "number" bindings))))
 	(if number
@@ -96,7 +96,7 @@
       (send/suspend make-result-page)
       ;; This finishes the session and does a redirect to the root
       ;; page.
-      (send-error (status-code moved-temp) #f "/" "/"))
+      (send-error (status-code temp-redirect) #f "/" "/"))
 
     ))