From 7460d8009fd1e43d4ec8e801ca2899795621e4f3 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Mon, 26 Aug 2002 13:10:57 +0000
Subject: [PATCH] Add a MAKE-HTTPD-OPTIONS combinator for a more visually
 pleasant layout for HTTPD-OPTIONS constructors.

---
 scheme/httpd/http-top.scm |  8 +++----
 scheme/httpd/options.scm  | 47 ++++++++++-----------------------------
 scheme/packages.scm       |  3 ++-
 3 files changed, 17 insertions(+), 41 deletions(-)

diff --git a/scheme/httpd/http-top.scm b/scheme/httpd/http-top.scm
index 7990729..09995a4 100644
--- a/scheme/httpd/http-top.scm
+++ b/scheme/httpd/http-top.scm
@@ -48,9 +48,7 @@
   (set-gid (->uid "nobody"))
   (set-uid (->gid "nobody"))
   (initialise-request-invariant-cgi-env)
-  (httpd (with-path-handler
-	  ph
-	  (with-port
-	   8001
-	   (with-root-directory "/usr/local/etc/httpd/htdocs")))))
+  (httpd (make-httpd-options with-path-handler ph
+			     with-port 8001
+			     with-root-directory "/usr/local/etc/httpd/htdocs")))
 
diff --git a/scheme/httpd/options.scm b/scheme/httpd/options.scm
index 5d3f5ea..bfcc95b 100644
--- a/scheme/httpd/options.scm
+++ b/scheme/httpd/options.scm
@@ -44,7 +44,7 @@
   (resolve-ips? httpd-options-resolve-ips? set-httpd-options-resolve-ips?!))
 
 ; default httpd-options generation
-(define (make-httpd-options)
+(define (make-default-httpd-options)
   (really-make-httpd-options 80		; port
 			     "/"	; root-directory
 			     #f		; icon-name
@@ -63,7 +63,7 @@
 ; creates a copy of a given httpd-option
 
 (define (copy-httpd-options options)
-  (let ((new-options (make-httpd-options)))
+  (let ((new-options (make-default-httpd-options)))
     (set-httpd-options-port! new-options
 			     (httpd-options-port options))
     (set-httpd-options-root-directory! new-options
@@ -94,7 +94,7 @@
   (lambda (new-value . stuff)
     (let ((new-options (if (not (null? stuff))
 			   (copy-httpd-options (car stuff))
-			   (make-httpd-options))))
+			   (make-default-httpd-options))))
       (set-option! new-options new-value)
       new-options)))
 
@@ -122,35 +122,12 @@
 (define with-resolve-ips?
   (make-httpd-options-transformer set-httpd-options-resolve-ips?!))
 
-;(define (with-httpd-options options-alist)
-;  (let ((new-options (make-httpd-options)))
-;    (let loop ((options-alist options-alist))
-;      (if (null? options-alist)
-;	  new-options
-;	  (begin
-;	    (case (caar options-alist)
-;	      (('port)
-;	       (set-httpd-options-port! new-options (cdar options-alist)))
-;	      (('root-directory)
-;	       (set-httpd-options-root-directory! new-options (cdar options-alist)))
-;	      (('fqdn)
-;	       (set-httpd-options-fqdn! new-options (cdar options-alist)))
-;	      (('reported-port)
-;	       (set-httpd-options-reported-port! new-options (cdar options-alist)))
-;	      (('path-handler)
-;	       (set-httpd-options-path-handler! new-options (cdar options-alist)))
-;	      (('server-admin)
-;	       (set-httpd-options-server-admin! new-options (cdar options-alist)))
-;	      (('simultaneous-requests)
-;	       (set-httpd-options-simultaneous-requests! new-options (cdar options-alist)))
-;	      (('logfile)
-;	       (set-httpd-options-logfile! new-options (cdar options-alist)))
-;	      (('syslog?)
-;	       (set-httpd-options-syslog?! new-options (cdar options-alist)))
-;	      (else
-;	       (begin
-;		 (format (current-error-port) 
-;			 "[httpd] Warning: Ignoring unknown option ~A."
-;			 (cdar options-alist)))))
-;	    (loop (cdr options-alist)))))))
-  
\ No newline at end of file
+(define (make-httpd-options . stuff)
+  (let loop ((options (make-default-httpd-options))
+	     (stuff stuff))
+    (if (null? stuff)
+	options
+	(let* ((transformer (car stuff))
+	       (value (cadr stuff)))
+	  (loop (transformer value options)
+		(cddr stuff))))))
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 9870fbc..64bc02e 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -253,7 +253,8 @@
 	  time->http-date-string))
 
 (define-interface httpd-make-options-interface
-  (export with-port
+  (export make-httpd-options
+	  with-port
 	  with-root-directory
 	  with-icon-name
 	  with-fqdn