diff --git a/http-top.scm b/http-top.scm index 954b401..09f1d26 100644 --- a/http-top.scm +++ b/http-top.scm @@ -52,7 +52,12 @@ ;;; env before starting. (define (httpd1) - (set-gid -2) ; Should be (set-uid (->uid "nobody")) - (set-uid -2) ; but NeXTSTEP loses. + (set-gid (->uid "nobody")) + (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"))))) + diff --git a/httpd-core.scm b/httpd-core.scm index 4dc1f05..27342d4 100644 --- a/httpd-core.scm +++ b/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. -;;; SERVER-ROOT-DIR is the server's working directory; it defaults to -;;; /usr/local/etc/httpd +;;; the procedure that actually deals with the request. -(define (httpd path-handler . args) - (let-optionals args ((port 80) - (root-dir "/usr/local/etc/httpd")) +(define (httpd options) + (let ((port (httpd-options-port options)) + (root-dir (httpd-options-root-directory options))) (init-http-log!) - (with-cwd root-dir - (bind-listen-accept-loop protocol-family/internet - - ;; Why is the output socket unbuffered? So that if the client - ;; closes the connection, we won't lose when we try to close the - ;; socket by trying to flush the output buffer. - (lambda (sock addr) ; Called once for every connection. - (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering - (fork-thread - (lambda () - ; Should propagate. ecch. - (with-current-input-port - (socket:inport sock) ; bind the - (with-current-output-port - (socket:outport sock) ; stdio ports, & - (set-port-buffering (current-input-port) bufpol/none) - (process-toplevel-request path-handler sock) - (close-socket sock))) ; do it. - ))) - port)))) + (with-cwd + root-dir + (bind-listen-accept-loop + protocol-family/internet + ;; Why is the output socket unbuffered? So that if the client + ;; closes the connection, we won't lose when we try to close the + ;; socket by trying to flush the output buffer. + (lambda (sock addr) ; Called once for every connection. + (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering + (fork-thread + (lambda () + (with-current-input-port + (socket:inport sock) ; bind the + (with-current-output-port + (socket:outport sock) ; stdio ports, & + (set-port-buffering (current-input-port) bufpol/none) + (process-toplevel-request sock options) + (close-socket sock))) ; do it. + ))) + 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 # 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)) - (portnum (my-port addr))) + (local-name (my-reported-fqdn addr options)) + (portnum (my-reported-port addr options))) (make-http-url (make-userhost #f #f local-name (number->string portnum)) @@ -349,7 +345,7 @@ (format out "~%

~A

~%" 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.

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 "

~%~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 (set-my-fqdn! fqdn) - (set! *my-fqdn* fqdn)) +(define *fqdn-cache* #f) -(define (my-port addr) - (or *my-port* +(define (my-reported-fqdn addr options) + (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)) diff --git a/httpd-options.scm b/httpd-options.scm new file mode 100644 index 0000000..908d8e1 --- /dev/null +++ b/httpd-options.scm @@ -0,0 +1,80 @@ +;;; http server in the Scheme Shell -*- Scheme -*- +;;; Mike Sperber + +;;; 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!)) diff --git a/modules.scm b/modules.scm index 54865c7..af022bf 100644 --- a/modules.scm +++ b/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! - set-my-port!)) +(define-interface httpd-make-options-interface + (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