sunet/scheme/httpd/options.scm

;;; 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
			     icon-name
			     fqdn
			     reported-port
			     path-handler
			     server-admin
			     simultaneous-requests
			     logfile
			     syslog?
			     resolve-ips?)
  httpd-options?
  (port httpd-options-port
	set-httpd-options-port!)
  (root-directory httpd-options-root-directory
		  set-httpd-options-root-directory!)
  ;; ICON-NAME specifies how to generate the links to
  ;; various decorative icons for the listings.  It can either be a
  ;; procedure which gets passed one of the icon tags in TAG->ICON and
  ;; is expected to return a link pointing to the icon.  If it is a
  ;; string, that is taken as prefix to which the names from TAG->ICON
  ;; are appended.
  (icon-name httpd-options-icon-name
	     set-httpd-options-icon-name!)
  (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!)
  (logfile httpd-options-logfile set-httpd-options-logfile!)
  (syslog? httpd-options-syslog? set-httpd-options-syslog?!)
  (resolve-ips? httpd-options-resolve-ips? set-httpd-options-resolve-ips?!))

; default httpd-options generation
(define (make-default-httpd-options)
  (really-make-httpd-options 80		; port
			     "/"	; root-directory
			     #f		; icon-name
			     #f		; fqdn
			     #f		; reported-port
			     #f		; path-handler
			     #f         ; server-admin
			     #f	        ; simultaneous-requests
			     #f
					; string: filename of logfile (directory must exist)
					; output-port: log to this port (e.g. (current-error-port))
					; #f: no logging
			     #t		; Do syslogging?
			     #t))	; Write host names instead of IPs in logfiles?

; creates a copy of a given httpd-option

(define (copy-httpd-options 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
				       (httpd-options-root-directory options))
    (set-httpd-options-icon-name! new-options
				  (httpd-options-icon-name 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))
    (set-httpd-options-logfile! new-options (httpd-options-logfile options))
    (set-httpd-options-syslog?! new-options (httpd-options-syslog? options))
    (set-httpd-options-resolve-ips?! new-options (httpd-options-resolve-ips? options))
    new-options))

; (make-httpd-options-transformer set-option!) -> lambda (new-value [httpd-option])
; creates a transformer for httpd-options
; the returned procedure is called with the new value for the option
; and optionally with the httpd-option to change
(define (make-httpd-options-transformer set-option!)
  (lambda (new-value . stuff)
    (let ((new-options (if (not (null? stuff))
			   (copy-httpd-options (car stuff))
			   (make-default-httpd-options))))
      (set-option! new-options new-value)
      new-options)))

; several transformers for port, root-directory, etc.
(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-icon-name
  (make-httpd-options-transformer set-httpd-options-icon-name!))
(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!))
(define with-logfile
  (make-httpd-options-transformer set-httpd-options-logfile!))
(define with-syslog?
  (make-httpd-options-transformer set-httpd-options-syslog?!))
(define with-resolve-ips?
  (make-httpd-options-transformer set-httpd-options-resolve-ips?!))

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