341 lines
12 KiB
Scheme
341 lines
12 KiB
Scheme
;;; http server in the Scheme Shell -*- Scheme -*-
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
|
|
;;; This file implements the core of an HTTP server: code to establish
|
|
;;; net connections, read and parse requests, and handler errors.
|
|
;;; It does not have the code to actually handle requests. That's up
|
|
;;; to other modules, and could vary from server to server. To build
|
|
;;; a complete server, you need to define request handlers (see below) --
|
|
;;; they determine how requests are to be handled.
|
|
;;;
|
|
;;; See RFC 2616 for the specification of the HTTP/1.1 protocol.
|
|
;;;
|
|
;;; The server is compatible with previous versions of HTTP in the way
|
|
;;; described in RFC 2616 19.6. See RFC 1945 for the specification of
|
|
;;; HTTP/1.0 and 0.9.
|
|
|
|
(define http-version-string
|
|
(string-append "HTTP/"
|
|
(number->string (car http-version))
|
|
"."
|
|
(number->string (cdr http-version))))
|
|
|
|
(define (httpd options)
|
|
(let ((port (httpd-options-port options))
|
|
(root-dir (httpd-options-root-directory options))
|
|
(rate-limiter
|
|
(cond
|
|
((httpd-options-simultaneous-requests options)
|
|
=> make-rate-limiter)
|
|
(else #f))))
|
|
(let-thread-fluid
|
|
logging
|
|
(make-logging)
|
|
(lambda ()
|
|
|
|
(init-http-log! options)
|
|
(with-syslog-destination
|
|
"httpd" #f #f #f
|
|
(lambda ()
|
|
(with-cwd
|
|
root-dir
|
|
(bind-prepare-listen-accept-loop
|
|
protocol-family/internet
|
|
(lambda ()
|
|
(cond ((httpd-options-post-bind-thunk options)
|
|
=> (lambda (thunk)
|
|
(thunk)))))
|
|
(lambda (sock addr)
|
|
(if rate-limiter
|
|
(begin
|
|
(rate-limit-block rate-limiter)
|
|
(rate-limit-open rate-limiter)))
|
|
|
|
(with-fatal-error-handler
|
|
(lambda (c decline)
|
|
(http-syslog (syslog-level notice) "error during connection negotiation~%")
|
|
(if rate-limiter
|
|
(rate-limit-close rate-limiter)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(socket-address->internet-address (socket-remote-address sock)))
|
|
(lambda (host-address service-port)
|
|
(if (and rate-limiter (http-syslog?))
|
|
(http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)
|
|
(rate-limiter-current-requests rate-limiter)))
|
|
|
|
(set-port-buffering (socket:outport sock) bufpol/block 4096)
|
|
(fork-thread
|
|
(lambda ()
|
|
;; If there is buffering for the input,
|
|
;; CGI scripts don't get the full request
|
|
(set-port-buffering (socket:inport sock) bufpol/none)
|
|
(process-toplevel-request sock host-address options)
|
|
(if (http-syslog?)
|
|
(http-syslog (syslog-level debug) "<~a>~a [closing]~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)))
|
|
(with-fatal-error-handler
|
|
(lambda (c decline)
|
|
(if (http-syslog?)
|
|
(http-syslog (syslog-level notice) "<~a>~a [error closing (~a)]~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)
|
|
c)))
|
|
(close-socket sock))
|
|
(if rate-limiter
|
|
(rate-limit-close rate-limiter))
|
|
(if (http-syslog?)
|
|
(http-syslog (syslog-level info) "<~a>~a [closed]~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)))))))))
|
|
port))))))))
|
|
|
|
|
|
;;; Top-level http request processor
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Read, parse, and handle a single http request. The only thing that makes
|
|
;;; this complicated is handling errors -- as a server, we can't just let the
|
|
;;; standard error handlers toss us into a breakpoint. We have to catch the
|
|
;;; error, send an error response back to the client if we can, and then keep
|
|
;;; on trucking. This means using the S48's condition system to catch and
|
|
;;; handle the various errors, which introduces a major point of R5RS
|
|
;;; incompatibiliy -- R5RS has no exception system. So if you were to port
|
|
;;; 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 sock host-address options)
|
|
;; This top-level error-handler catches *all* uncaught errors and warnings.
|
|
;; If the error condition is a reportable HTTP error, we send a response back
|
|
;; to the client. In any event, we abort the transaction, and return from
|
|
;; PROCESS-TOPLEVEL-REQUEST.
|
|
;;
|
|
;; We *oughta* map non-http-errors into replies anyway.
|
|
(with-fatal-error-handler*
|
|
(lambda (c decline)
|
|
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)
|
|
c)
|
|
(with-fatal-error-handler*
|
|
(lambda (c decline)
|
|
(http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)
|
|
c))
|
|
(lambda ()
|
|
(shutdown-socket sock shutdown/sends+receives)
|
|
(http-syslog (syslog-level info) "<~a>~a [shut down]~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)))))
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda ()
|
|
(with-fatal-error-handler*
|
|
(lambda (c decline)
|
|
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)
|
|
c)
|
|
(cond
|
|
((http-error? c)
|
|
(apply (lambda (status-code req . args)
|
|
(values req
|
|
(apply make-error-response
|
|
status-code req
|
|
args)))
|
|
(condition-stuff c)))
|
|
((fatal-syntax-error? c)
|
|
(values #f
|
|
(apply make-error-response (status-code bad-request)
|
|
#f ; No request yet.
|
|
(condition-stuff c))))
|
|
((not (and (exception? c)
|
|
(eq? (exception-reason c);;?? ->
|
|
(enum exception os-error))));;?? ->
|
|
;;which cases is this supposed to catch excactly? broken
|
|
;;connection to client? If so, does it work?
|
|
(values #f
|
|
(apply make-error-response (status-code internal-error)
|
|
#f ; don't know
|
|
c)))
|
|
(else
|
|
(decline))))
|
|
(lambda ()
|
|
(let ((initial-req (parse-http-request sock options)))
|
|
(check-major-http-version initial-req)
|
|
(let redirect-loop ((req initial-req))
|
|
(let response-loop ((response ((httpd-options-request-handler options)
|
|
(http-url-path (request-url req))
|
|
req)))
|
|
(cond
|
|
((input-response? response)
|
|
(response-loop
|
|
((input-response-body-maker response)
|
|
(socket:inport sock))))
|
|
((nph-response? response)
|
|
(values req response))
|
|
((eq? (response-code response) (status-code redirect));internal redirect
|
|
(redirect-loop (redirect-request req response sock options)))
|
|
(else
|
|
(values req response)))))))))
|
|
(lambda (req response)
|
|
|
|
(send-http-response req response
|
|
(socket:inport sock)
|
|
(socket:outport sock)
|
|
options)
|
|
)))))
|
|
|
|
|
|
;;; REDIRECT-REQUEST relies on that nothing is read out from SOCKET.
|
|
|
|
(define (redirect-request req response socket options)
|
|
(let* ((new-location-uri (redirect-body-location (response-body response)))
|
|
(url (with-fatal-error-handler*
|
|
(lambda (c decline)
|
|
(if (fatal-syntax-error? c)
|
|
(http-error (status-code internal-error) req
|
|
(format #f "Bad redirection out from CGI program: ~%~a"
|
|
(cdr c)))
|
|
(decline c)))
|
|
(lambda ()
|
|
;; (future) NOTE: With this, a redirection may change the
|
|
;; protocol in use (currently, the server only supports one of
|
|
;; it). This might be inapplicable.
|
|
(url-string->http-url new-location-uri)))))
|
|
|
|
(make-request "GET"
|
|
new-location-uri
|
|
url
|
|
(request-version req) ; did not change
|
|
'() ; no rfc822 headers
|
|
(request-socket req))))
|
|
|
|
;;; Read and parse an http request from INPORT.
|
|
|
|
(define (parse-http-request sock options)
|
|
(let ((line (read-crlf-line (socket:inport sock))))
|
|
;; Blat out some logging info.
|
|
(if (http-syslog?)
|
|
(call-with-values
|
|
(lambda ()
|
|
(socket-address->internet-address (socket-remote-address sock)))
|
|
(lambda (host-address service-port)
|
|
(http-syslog (syslog-level info) "<~a>~a: ~a~%"
|
|
(pid)
|
|
(format-internet-host-address host-address)
|
|
line))))
|
|
|
|
(if (eof-object? line)
|
|
(fatal-syntax-error "EOF while parsing request.")
|
|
|
|
(let* ((elts (string->words line)) ; Split at white-space.
|
|
(version (case (length elts)
|
|
((2) '(0 . 9))
|
|
((3) (parse-http-version (caddr elts)))
|
|
(else (fatal-syntax-error "Bad Request Line."))))
|
|
(meth (car elts))
|
|
(request-uri (cadr elts))
|
|
(url (url-string->http-url request-uri))
|
|
(headers (if (equal? version '(0 . 9))
|
|
'()
|
|
(read-rfc822-headers (socket:inport sock)))))
|
|
(make-request meth request-uri url version headers sock)))))
|
|
|
|
|
|
(define parse-http-version
|
|
(let ((re (make-regexp "^HTTP/([0-9]+)\\.([0-9]+)$"))
|
|
(lose (lambda (s) (fatal-syntax-error "Bad HTTP version" s))))
|
|
(lambda (vstring)
|
|
(let ((m (regexp-exec re vstring)))
|
|
(if m
|
|
(cons (or (string->number (match:substring m 1) 10) (lose vstring))
|
|
(or (string->number (match:substring m 2) 10) (lose vstring)))
|
|
(lose vstring))))))
|
|
|
|
|
|
;;; check whether the request's major HTTP version is greater than the
|
|
;;; server's major HTTP version; if so, send 505 (Version not supported).
|
|
|
|
(define (check-major-http-version req)
|
|
(if (> (car (request-version req)) (car http-version))
|
|
(http-error (status-code version-not-supp) req)))
|
|
|
|
|
|
;;; Split string into a list of whitespace-separated strings.
|
|
;;; This could have been trivially defined in scsh as (field-splitter " \t\n")
|
|
;;; but I hand-coded it because it's short, and I didn't want invoke the
|
|
;;; regexp machinery for something so simple.
|
|
|
|
(define non-whitespace (char-set-complement char-set:whitespace))
|
|
|
|
(define (string->words s)
|
|
(let recur ((start 0))
|
|
(cond ((string-index s non-whitespace start) =>
|
|
(lambda (start)
|
|
(cond ((string-index s char-set:whitespace start) =>
|
|
(lambda (end)
|
|
(cons (substring s start end)
|
|
(recur end))))
|
|
(else (list (substring s start (string-length s)))))))
|
|
(else '()))))
|
|
|
|
(define (send-http-headers response port)
|
|
(display http-version-string port)
|
|
(write-char #\space port)
|
|
(display (status-code-number (response-code response)) port)
|
|
(write-char #\space port)
|
|
(display (or (response-message response)
|
|
(status-code-message (response-code response)))
|
|
port)
|
|
(write-crlf port)
|
|
|
|
(send-http-header-fields
|
|
(list (cons 'server (string-append "Scheme Untergrund " sunet-version-identifier))
|
|
(cons 'content-type (response-mime response))
|
|
(cons 'date (rfc822-time->string (response-seconds response))))
|
|
port)
|
|
(send-http-header-fields (response-extras response) port)
|
|
|
|
(write-crlf port))
|
|
|
|
|
|
(define (send-http-response request response input-port output-port options)
|
|
(cond
|
|
;;if request-record could not be built (i.e. either
|
|
;;fatal-syntax-error was called because of an erroneous request
|
|
;;line, or an server-internal error (not an os-error) occurred)
|
|
;;and therefore HTTP-version of request is not known, answer
|
|
;;with HTTP/1.0
|
|
((not request)
|
|
(send-http-headers response output-port)
|
|
(display-http-body (response-body response) input-port output-port options))
|
|
;;no CLF-logging)
|
|
((nph-response? response)
|
|
(display-http-body (nph-response-body response) input-port output-port options)
|
|
(http-log request (status-code ok))); guess the status code
|
|
(else
|
|
(if (not (v0.9-request? request))
|
|
(send-http-headers response output-port))
|
|
(if (not (or (string=? (request-method request) "HEAD")
|
|
(no-body? (response-body response)))) ;; response messages which MUST NOT include a message-body
|
|
(display-http-body (response-body response) input-port output-port options))
|
|
(http-log request (response-code response)))))
|
|
|
|
(define (send-http-header-fields headers port)
|
|
(for-each (lambda (pair)
|
|
(display (car pair) port)
|
|
(write-char #\: port)
|
|
(display (cdr pair) port)
|
|
(write-crlf port))
|
|
headers))
|
|
|