Make the various httpd options into an abstract datatype.

http-top.scm

@@ -52,7 +52,12 @@
 ;;; env before starting.
 
 (define (httpd1)
-  (set-gid -2)  ; Should be (set-uid (->uid "nobody")) 
+  (set-gid (->uid "nobody"))
-  (set-uid -2)	; but NeXTSTEP loses. 
+  (set-uid (->gid "nobody"))
   (initialise-request-invariant-cgi-env)
-  (httpd ph 8001 "/usr/local/etc/httpd/htdocs"))
+  (httpd (with-path-handler
+	  ph
+	  (with-port
+	   8001
+	   (with-root-directory "/usr/local/etc/httpd/htdocs")))))
+

httpd-core.scm

@@ -43,13 +43,6 @@
 ;;; Configurable Variables
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; Address for config error reports
-(define server/admin "sperber@informatik.uni-tuebingen.de")
-(define (set-server/admin! s)
-  (set! server/admin s))
-
-
-
 (define *http-log?* #t)
 (define *http-log-port* #f)
 (define *http-log-lock* (make-lock))
@@ -66,37 +59,35 @@
 	(release-lock *http-log-lock*))))
 
 
-;;; (httpd path-handler [port server-root-dir])
+;;; (httpd options)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; The server top-level. PATH-HANDLER is the top-level request path handler --
-;;; the procedure that actually deals with the request. PORT defaults to 80.
+;;; the procedure that actually deals with the request.
-;;; SERVER-ROOT-DIR is the server's working directory; it defaults to
-;;;     /usr/local/etc/httpd
 
-(define (httpd path-handler . args)
+(define (httpd options)
-  (let-optionals args ((port 80)
+  (let ((port (httpd-options-port options))
-		       (root-dir "/usr/local/etc/httpd"))
+	(root-dir (httpd-options-root-directory options)))
     (init-http-log!)
-    (with-cwd root-dir
+    (with-cwd
-      (bind-listen-accept-loop protocol-family/internet
+     root-dir
-				       
+     (bind-listen-accept-loop
-	;; Why is the output socket unbuffered? So that if the client
+      protocol-family/internet
-	;; closes the connection, we won't lose when we try to close the
+      ;; Why is the output socket unbuffered? So that if the client
-	;; socket by trying to flush the output buffer.
+      ;; closes the connection, we won't lose when we try to close the
-        (lambda (sock addr) ; Called once for every connection.
+      ;; socket by trying to flush the output buffer.
-	  (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
+      (lambda (sock addr)		; Called once for every connection.
-	  (fork-thread 
+	(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
-	   (lambda ()	
+	(fork-thread 
-					; Should propagate. ecch.
+	 (lambda ()	
-	     (with-current-input-port 
+	   (with-current-input-port 
-	      (socket:inport  sock)		    ; bind the
+	    (socket:inport sock)	; bind the
-	      (with-current-output-port 
+	    (with-current-output-port 
-	       (socket:outport sock)	    ; stdio ports, &
+	     (socket:outport sock)	; stdio ports, &
-	       (set-port-buffering (current-input-port) bufpol/none)
+	     (set-port-buffering (current-input-port) bufpol/none)
-	       (process-toplevel-request path-handler sock)
+	     (process-toplevel-request sock options)
-	       (close-socket sock))) ; do it.
+	     (close-socket sock)))	; do it.
-	     )))
+	   )))
-	port))))
+      port))))
 
 ;;; Top-level http request processor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -110,7 +101,7 @@
 ;;; this code to some other Scheme, you'd really have to sit down and think
 ;;; about this issue for a minute.
 
-(define (process-toplevel-request handler sock)
+(define (process-toplevel-request sock options)
   ;; This top-level error-handler catches *all* uncaught errors and warnings.
   ;; If the error condition is a reportable HTTP error, we send a reply back 
   ;; to the client. In any event, we abort the transaction, and return from
@@ -120,7 +111,10 @@
   (with-fatal-error-handler (lambda (c decline)		; No call to decline
 			      (http-log "Error! ~s~%" c)
 			      (if (http-error? c)	; -- we handle all.
-				  (apply send-http-error-reply
+				  (apply (lambda (reply-code req . args)
+					   (apply send-http-error-reply
+						  reply-code req options
+						  args))
 					 (condition-stuff c))))
 
     (let ((req (with-fatal-error-handler	; Map syntax errors
@@ -131,7 +125,9 @@
 				"Request parsing error -- report to client maintainer."
 				(condition-stuff c))
 			 (decline)))			   ; Actual work:
-		 (parse-http-request sock))))		   ; (1) Parse request.
+		 (parse-http-request sock options)))	   ; (1) Parse request.
+	  (handler
+	   (httpd-options-path-handler options)))
       (handler (http-url:path (request:url req)) req))))   ; (2) Deal with it.
 
 
@@ -185,7 +181,7 @@
 ;;; 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)
+(define (parse-http-request sock options)
   (let ((line (read-crlf-line)))
 
     ;; Blat out some logging info.
@@ -209,7 +205,7 @@
 
 	  (let* ((meth (car elts))
 		 (uri-string (cadr elts))
-		 (url (parse-http-servers-url-fragment uri-string sock))
+		 (url (parse-http-servers-url-fragment uri-string sock options))
 		 (headers (if (equal? version '(0 . 9)) '()
 			      (read-rfc822-headers))))
 	    (make-request meth uri-string url version headers sock))))))
@@ -221,7 +217,7 @@
 ;;; computed the default host and port at server-startup time, instead of
 ;;; on every request.
 
-(define (parse-http-servers-url-fragment uri-string 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."
@@ -235,8 +231,8 @@
 	    ;; Interpolate the userhost struct from our net connection.
 	    (if (and (pair? path) (string=? (car path) ""))
 		(let* ((addr (socket-local-address socket))
-		       (local-name (my-fqdn addr))
+		       (local-name (my-reported-fqdn addr options))
-		       (portnum (my-port addr)))
+		       (portnum (my-reported-port addr options)))
 		  (make-http-url (make-userhost #f #f
 						local-name
 						(number->string portnum))
@@ -349,7 +345,7 @@
   (format out "<BODY>~%<H1>~A</H1>~%" message))
 
 
-;;; (send-http-error-reply reply-code req [message . extras])
+;;; (send-http-error-reply reply-code req options [message . extras])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Take an http-error condition, and format it into a reply to the client.
 ;;;
@@ -365,11 +361,11 @@
 ;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll
 ;;; leave it in to play it safe.)
 
-(define (send-http-error-reply reply-code req . args)
+(define (send-http-error-reply reply-code req options . args)
   (ignore-errors (lambda ()	; Ignore errors -- see note above.
-		   (apply really-send-http-error-reply reply-code req args))))
+		   (apply really-send-http-error-reply reply-code req options args))))
 
-(define (really-send-http-error-reply reply-code req . args)
+(define (really-send-http-error-reply reply-code req options . args)
   (http-log "sending error-reply ~a ~%" reply-code)
 
   (let* ((message (if (pair? args) (car args)))
@@ -462,7 +458,7 @@ misconfiguration and was unable to complete your request.
 <P>
 Please inform the server administrator, ~A, of the circumstances leading to
 the error, and time it occured.~%"
-		     server/admin)
+		     (httpd-options-server-admin options))
 	     (if message (format out "<P>~%~a~%" message)))))
 
       ((= reply-code http-reply/not-implemented)
@@ -495,23 +491,18 @@ the requested method (~A).~%"
 ;;; unqualified hostname.  Also, in case of aliased names, you just
 ;;; might get the wrong one.  Furthermore, you may get screwed in the
 ;;; presence of a server accelerator such as Squid.
-;;;
-;;; In these cases, and on NeXTSTEP, you'll have to set it by hand.
 
-(define (my-fqdn addr)
-  (or *my-fqdn*
-      (begin 
-	(set-my-fqdn! (host-info:name (host-info addr)))
-	*my-fqdn*)))
 
-(define *my-fqdn* #f)
+(define *fqdn-cache* #f)
-(define (set-my-fqdn! fqdn)
-  (set! *my-fqdn* fqdn))
 
-(define (my-port addr)
+(define (my-reported-fqdn addr options)
-  (or *my-port*
+  (or *fqdn-cache*
+      (begin
+      (set! *fqdn-cache* (or (httpd-options-fqdn options)
+			     (host-info:name (host-info addr))))
+      *fqdn-cache*)))
+
+(define (my-reported-port addr options)
+  (or (httpd-options-reported-port options)
       (receive (ip-addr portnum) (socket-address->internet-address addr)
 	portnum)))
-(define *my-port* #f)
-(define (set-my-port! portnum)
-  (set! *my-port* portnum))

httpd-options.scm

@@ -0,0 +1,80 @@
+;;; http server in the Scheme Shell	-*- Scheme -*-
+;;; Mike Sperber <sperber@informatik.uni-tuebingen.de>
+
+;;; This package manages options to the http server as an abstract
+;;; data type.
+
+(define-record-type httpd-options :httpd-options
+  (really-make-httpd-options port
+			     root-directory
+			     fqdn
+			     reported-port
+			     path-handler
+			     server-admin
+			     simultaneous-requests)
+  httpd-options?
+  (port httpd-options-port
+	set-httpd-options-port!)
+  (root-directory httpd-options-root-directory
+		  set-httpd-options-root-directory!)
+  (fqdn httpd-options-fqdn
+	set-httpd-options-fqdn!)
+  (reported-port httpd-options-reported-port
+		 set-httpd-options-reported-port!)
+  (path-handler httpd-options-path-handler
+		set-httpd-options-path-handler!)
+  (server-admin httpd-options-server-admin
+		set-httpd-options-server-admin!)
+  (simultaneous-requests httpd-options-simultaneous-requests
+			 set-httpd-options-simultaneous-requests!))
+
+(define (make-httpd-options)
+  (really-make-httpd-options 80		; port
+			     "/"	; root-directory
+			     #f		; fqdn
+			     #f		; reported-port
+			     #f		; path-handler
+			     "sperber@informatik.uni-tuebingen.de" ; server-admin
+			     #f))	; simultaneous-requests
+
+(define (copy-httpd-options options)
+  (let ((new-options (make-httpd-options)))
+    (set-httpd-options-port! new-options
+			     (httpd-options-port options))
+    (set-httpd-options-root-directory! new-options
+				       (httpd-options-root-directory options))
+    (set-httpd-options-fqdn! new-options
+			     (httpd-options-fqdn options))
+    (set-httpd-options-reported-port! new-options
+				      (httpd-options-reported-port options))
+    (set-httpd-options-path-handler! new-options
+				     (httpd-options-path-handler options))
+    (set-httpd-options-server-admin! new-options
+				     (httpd-options-server-admin options))
+    (set-httpd-options-simultaneous-requests!
+     new-options
+     (httpd-options-simultaneous-requests options))
+    new-options))
+
+(define (make-httpd-options-transformer set-option!)
+  (lambda (new-value . stuff)
+    (let ((new-options (if (not (null? stuff))
+			   (copy-httpd-options (car stuff))
+			   (make-httpd-options))))
+      (set-option! new-options new-value)
+      new-options)))
+
+(define with-port
+  (make-httpd-options-transformer set-httpd-options-port!))
+(define with-root-directory
+  (make-httpd-options-transformer set-httpd-options-root-directory!))
+(define with-fqdn
+  (make-httpd-options-transformer set-httpd-options-fqdn!))
+(define with-reported-port
+  (make-httpd-options-transformer set-httpd-options-reported-port!))
+(define with-path-handler
+  (make-httpd-options-transformer set-httpd-options-path-handler!))
+(define with-server-admin
+  (make-httpd-options-transformer set-httpd-options-server-admin!))
+(define with-simultaneous-requests
+  (make-httpd-options-transformer set-httpd-options-simultaneous-requests!))

modules.scm

@@ -207,12 +207,8 @@
 (define-interface httpd-core-interface
   (export server/version
 	  server/protocol
-	  server/admin
-	  set-server/admin!
 
 	  http-log
-	  *http-log?*
-	  *http-log-port*
 
 	  httpd
 
@@ -266,13 +262,28 @@
 
 	  time->http-date-string
 	  begin-http-header
-	  send-http-error-reply
+	  send-http-error-reply))
 
-	  set-my-fqdn!
+(define-interface httpd-make-options-interface
-	  set-my-port!))
+  (export with-port
+	  with-root-directory
+	  with-fqdn
+	  with-reported-port
+	  with-path-handler
+	  with-server-admin
+	  with-simultaneous-requests))
+
+(define-interface httpd-read-options-interface
+  (export httpd-options-port
+	  httpd-options-root-directory
+	  httpd-options-fqdn
+	  httpd-options-reported-port
+	  httpd-options-path-handler
+	  httpd-options-server-admin
+	  httpd-options-simultaneous-requests))
 
 (define-structure httpd-core httpd-core-interface
-  (open threads
+  (open threads locks
 	thread-fluids               ; fork-thread
 	scsh
 	receiving
@@ -291,10 +302,18 @@
 	uri
 	url
 	formats
+	format-net
 	sunet-utilities
+	httpd-read-options
 	scheme)
   (files httpd-core))
 
+(define-structures ((httpd-make-options httpd-make-options-interface)
+		    (httpd-read-options httpd-read-options-interface))
+  (open scheme
+	define-record-types)
+  (files httpd-options))
+
 
 ;;; For parsing submissions from HTML forms.
 (define-interface parse-html-forms-interface