sunet/scheme/httpd/options.scm

156 lines
6.1 KiB
Scheme

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