scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make the various httpd options into an abstract datatype.

This commit is contained in:
sperber 2002-02-23 14:42:50 +00:00
parent 666ac9897d
commit 619b0b6d67
4 changed files with 168 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
http-top.scm
View File

@ -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")))))

115
httpd-core.scm
View File

@ -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 #<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))
(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 "<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*
(define *fqdn-cache* #f)
(define (my-reported-fqdn addr options)
(or *fqdn-cache*
(begin
(set-my-fqdn! (host-info:name (host-info addr)))
*my-fqdn*)))
(set! *fqdn-cache* (or (httpd-options-fqdn options)
(host-info:name (host-info addr))))
*fqdn-cache*)))
(define *my-fqdn* #f)
(define (set-my-fqdn! fqdn)
(set! *my-fqdn* fqdn))
(define (my-port addr)
(or *my-port*
(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))

80
httpd-options.scm Normal file
View File

@ -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!))

35
modules.scm
View File

@ -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