;;; http server in the Scheme Shell -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; 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 path handlers (see below) --
;;; they determine how requests are to be handled.
;;;
;;; The RFC detailing the HTTP 1.0 protocol, RFC 1945, can be found at
;;; http://www.w3.org/Protocols/rfc1945/rfc1945
;;; (httpd options)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The server top-level. PATH-HANDLER is the top-level request path handler --
;;; the procedure that actually deals with the request.
(define server/protocol "HTTP/1.0")
(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))))
(init-http-log! options)
(with-syslog-destination
"httpd" #f #f #f
(lambda ()
(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)
(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/none) ; No buffering
(fork-thread
(lambda ()
(set-port-buffering (current-input-port) 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))
(decline))))
(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-http-error-response
status-code req
args)))
(condition-stuff c)))
((fatal-syntax-error? c)
(values #f
(apply make-http-error-response http-status/bad-request
#f ; No request yet.
"Request parsing error -- report to client maintainer."
(condition-stuff c))))
(else
(decline))))
(lambda ()
(let* ((req (parse-http-request sock options))
(response ((httpd-options-path-handler options)
(http-url:path (request:url req))
req)))
(values req response)))))
(lambda (req response)
(send-http-response req response (socket:outport sock) options)
(http-log req http-status/ok))))))
;;;; HTTP request parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; This code provides procedures to read requests from an input
;;;; port.
;;; Read and parse an http request from INPORT.
;;;
;;; Note: this parser parses the URI into an http URL record. If the URI
;;; isn't an http URL, the parser fails. This may not be right. There's
;;; nothing in the http protocol to prevent you from passing a non-http
;;; 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 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 HTTP version.")))))
(let* ((meth (car elts))
(uri-string (cadr elts))
(url (parse-http-servers-url-fragment uri-string sock options))
(headers (if (equal? version '(0 . 9)) '()
(read-rfc822-headers (socket:inport sock)))))
(make-request meth uri-string url version headers sock))))))
;;; Parse the URL, but if it begins without the "http://host:port" prefix,
;;; interpolate one from SOCKET. It would sleazier but faster if we just
;;; computed the default host and port at server-startup time, instead of
;;; on every request.
(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 #
~s~%" x)) extras)
(write-string "
\n" port))) (create-response (lambda (headers writer-proc) (make-response status-code (status-code->text status-code) (time) "text/html" headers (make-writer-body writer-proc))))) (cond ;; This error response requires two args: message is the new URI: field, ;; and the first EXTRA is the older Location: field. ((or (= status-code http-status/moved-temp) (= status-code http-status/moved-perm)) (create-response (list (cons 'uri message) (cons 'location (car extras))) (lambda (port options) (title-html port "Document moved") (format port "This document has ~A moved to a new location.~%" (if (= status-code http-status/moved-temp) "temporarily" "permanently") message) (close-html port)))) ((= status-code http-status/bad-request) (create-response '() (lambda (port options) (generic-title port) (write-string "
Client sent a query that this server could not understand.\n"
port)
(if message (format port "
~%Reason: ~A~%" message))
(close-html port))))
((= status-code http-status/unauthorized)
(create-response
(list (cons 'WWW-Authenticate message)) ; Vas is das?
(lambda (port options)
(title-html port "Authorization Required")
(write-string "
Browser not authentication-capable or\n" port) (write-string "authentication failed.\n" port) (if message (format port "~a~%" message)) (close-html port)))) ((= status-code http-status/forbidden) (create-response '() (lambda (port options) (title-html port "Request not allowed.") (format port "Your client does not have permission to perform a ~A~%" (request:method req)) (format port "operation on url ~a.~%" (request:uri req)) (if message (format port "
~%~a~%" message)) (close-html port)))) ((= status-code http-status/not-found) (create-response '() (lambda (port options) (title-html port "URL not found") (write-string "
The requested URL was not found on this server.\n" port) (if message (format port "
~%~a~%" message)) (close-html port)))) ((= status-code http-status/internal-error) (http-syslog (syslog-level error) "internal-error: ~A" message) (create-response '() (lambda (port options) (generic-title port) (format port "The server encountered an internal error or 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.~%" (httpd-options-server-admin options)) (if message (format port "
~%~a~%" message)) (close-html port)))) ((= status-code http-status/not-implemented) (create-response '() (lambda (port options) (generic-title port) (format port "This server does not currently implement the requested method (~A).~%" (request:method req)) (if message (format port "
~a~%" message)) (close-html port)))) (else (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code) (create-response '() (lambda (port options) (generic-title port) (close-html port))))))) (define (title-html out message) (format out "
~%
~%~%~%" message) (format out "