sunet/httpd-core.scm

;;; http server in the Scheme Shell	-*- Scheme -*-
;;; Olin Shivers <shivers@lcs.mit.edu>

;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.

;;; Problems:
;;; Need to html-quote URI's when printing them out to HTML text.

;;; 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.
;;;
;;; A draft document detailing the HTTP 1.0 protocol can be found at
;;; http://www.w3.org/hypertext/WWW/Protocols/HTTP1.0/
;;;      draft-ietf-http-spec.html

;;; Imports and non-R4RS'isms
;;;	\r \n in strings for cr and lf.
;;;	receive values				(MV return)
;;;	scsh system calls
;;; 	rfc822 header parsing
;;;	crlf-io					(read cr/lf terminated lines)
;;;	when, unless, switch, ?			(conditionals)
;;;	uri, url packages
;;; 	defrec package				(record structures)
;;;	defenum					(enumerated types)
;;;	ignore-errors				(HANDLE package)
;;;     string hacking stuff
;;;	char-set stuff
;;;     format					(Formatted output)
;;;	httpd error stuff
;;;	condition-stuff				(S48 error conditions)

;;; Constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define server/version  "Scheme-Underground/1.0")
(define server/protocol "HTTP/1.0")

; default: no logging
; initialized by init-http-log!
(define http-log (lambda a #f))      ; makes logging in CLF
(define http-syslog (lambda a #f))   ; makes syslog
(define *http-syslog?* #f)           ; trigger used to avoid
                                     ;  unnecessary computations

(define (init-http-log! options)
  (init-http-port-log! (httpd-options-logfile options))
  (init-http-syslog! (httpd-options-syslog? options)))

(define (init-http-port-log! logfile)
  (let ((logport 
	 (cond
	  ((string? logfile)            ; try to open logfile for appending (output)
	   (call-with-current-continuation
	    (lambda (exit)
	      (with-errno-handler*
	       (lambda (errno packet)
		 (format (current-error-port) 
			 "[httpd] Warning: An error occured while opening ~S for writing (~A).
                 Logging now to stderr.~%"
			 logfile
			 (car packet))
		 (exit (current-error-port)))
	       (lambda ()
		 (open-output-file logfile 
				   (bitwise-ior open/create open/append)))))))
	  ((output-port? logfile)       ; we were given an output port, so let's use it
	   logfile)
	  ((eq? logfile #f)             ; no logging demanded
	   #f)
	; unexpected value of logfile; we'll use (current-error-port) instead
	  (else
	   (format (current-error-port)
		   "[httpd] Warning: Logfile was not specified correctly (given: ~S).~%
                 Logging now to stderr.\n"
		   logfile)
	   (current-error-port)))))

    (if logfile                         ; if logging was specified, set up the logger
	(set! http-log (make-http-log-proc logport)))))
	; alternative-clause: default values of *http-syslog?* and http-log

(define (init-http-syslog! syslog?)
  (if syslog?
      (let ((http-syslog-lock (make-lock)))
	(set! *http-syslog?* #t)
	(set! http-syslog
	      (lambda (level fmt . args)
		(obtain-lock http-syslog-lock)
		(syslog level
			(apply format #f fmt args))
		(release-lock http-syslog-lock))))))
	
(define (make-http-log-proc http-log-port)
  (let ((http-log-lock (make-lock)))
;    (display "--- MARK (server started) ---\n" http-log-port)
    (lambda (req reply-code)
      (if req
	  (begin
	    (obtain-lock http-log-lock)
	    (display (make-CLF
		      (receive (host-address _) 
			       (socket-address->internet-address 
				(socket-remote-address (request:socket req)))
			       (format-internet-host-address host-address))
		      (request:method req)                         ; request method
		      (uri-path-list->path 
		       (http-url:path (request:url req)))          ; requested file
		      (version->string (request:version req))      ; protocol version
		      reply-code
		      23                                           ; filesize (unknown)
		      (get-header (request:headers req) 'referer)
		      (get-header (request:headers req) 'user-agent))
		     http-log-port)
	    (force-output http-log-port)
	    (release-lock http-log-lock))))))
  
; returns a string for a CLF entry (Common Log Format)
; note: till now, we do not log the user's time zone code
(define (make-CLF remote-ip request-type requested-file protocol http-code filesize referer user-agent)
  (format #f "~A - - ~A ~S ~A ~A ~S ~S~%"
		(or remote-ip "-")
		(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date))     ; +0000 as we don't know
		(string-join (list request-type requested-file protocol))
		; Unfortunately, we first split the request line into 
		; method/request-type etc. and put it together here.
		; Files conform to CLF are expected to print the original line.
		(or http-code "-")
		(or filesize "-")
		(or referer "")
		(or user-agent "")))

;;; (httpd options)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The server top-level. PATH-HANDLER is the top-level request path handler --
;;; the procedure that actually deals with the request.

(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 ()	
		  (with-current-input-port 
		   (socket:inport sock)
		   (with-current-output-port 
		    (socket:outport sock)
		    (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 reply 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 R4RS
;;; incompatibiliy -- R4RS 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 reply 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)		; No call to decline
			      (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
					(pid)
					(format-internet-host-address host-address)
					c)
			      (if (http-error? c)	; -- we handle all.
				  (apply (lambda (reply-code req . args)
					   (apply send-http-error-reply
						  reply-code req options
						  args))
					 (condition-stuff 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))
				   (shutdown-socket sock shutdown/sends+receives)
				   (http-syslog (syslog-level info) "<~a>~a [shut down]~%"
					     (pid)
					     (format-internet-host-address host-address)))))

    (let ((req (with-fatal-error-handler	; Map syntax errors
	           (lambda (c decline)		; to http errors.
		     (if (fatal-syntax-error? c)
			 (apply http-error http-reply/bad-request
				#f	; No request yet.	
				"Request parsing error -- report to client maintainer."
				(condition-stuff c))
			 (decline)))			   ; Actual work:
		 (parse-http-request sock options)))	   ; (1) Parse request.
	  (handler
	   (httpd-options-path-handler options)))
      (handler (cdr (http-url:path (request:url req))) req)   ; (2) Deal with it. (skipped initial "/")
      (http-log req http-reply/ok))))



;;;; HTTP request parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; This code defines the http REQUEST data structure, and provides
;;;; code to read requests from an input port.

(define-record request
  method		; A string such as "GET", "PUT", etc.
  uri			; The escaped URI string as read from request line.
  url			; An http URL record (see url.scm).
  version		; A (major . minor) integer pair.
  headers		; An rfc822 header alist (see rfc822.scm).
  socket)		; The socket connected to the client.

(define-record-discloser type/request
  (lambda (req)
    (list 'request 
	  (request:method req)
	  (request:uri req)
	  (request:url req)
	  (request:version req)
	  (request:headers req)
	  (request:socket req))))
;;; A http protocol version is an integer  pair: (major . minor).

(define (version< v1 v2)
  (or (< (car v1) (car v2))
      (and (= (car v1) (car v2))
	   (< (cdr v1) (cdr v2)))))

(define (version<= v1 v2) (not (version< v2 v1)))

(define (v0.9-request? req)
  (version<= (request:version req) '(0 . 9)))


(define (version->string v)
  (string-append "HTTP/"
		 (number->string (car v))
		 "."
		 (number->string (cdr v))))


;;; 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)))
;    (display line (current-error-port)) (newline (current-error-port))
    ;; 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))))
	    (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 #<fragment> suffix."
			    uri-string)

	(if scheme
	    (if (string-ci=? scheme "http") ; Better be an http url.
		(parse-http-url path search #f)
		(fatal-syntax-error "Non-HTTP URL" uri-string))

	    ;; Interpolate the userhost struct from our net connection.
	    (if (and (pair? path) (string=? (car path) ""))
		(let* ((addr (socket-local-address socket))
		       (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))
				 (map unescape-uri path) ; DON'T Skip initial /.
				 search
				 #f))

		(fatal-syntax-error "Path fragment must begin with slash"
				    uri-string))))))


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

;;; 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 ((char-set-index s non-whitespace start) =>
        (lambda (start)
	  (cond ((char-set-index s char-set:whitespace start) => 
	      (lambda (end)
		(cons (substring s start end)
		      (recur end))))
	     (else (list (substring s start (string-length s)))))))
       (else '()))))


;;;; Sending replies
;;;;;;;;;;;;;;;;;;;;

;;; Reply codes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (define http-reply/ok 200), etc.
;;; Also, build an alist HTTP-REPLY-TEXT-TABLE mapping integer reply codes
;;; to their diagnostic text messages.

(define-syntax define-http-reply-codes
  (syntax-rules ()
    ((define-http-reply-codes table set (name val msg) ...)
     (begin (define table '((val . msg) ...))
	    (define-enum-constant set name val)
	    ...))))

(define-http-reply-codes http-reply-text-table http-reply
  (ok			200 "OK")
  (created		201 "Created")
  (accepted		202 "Accepted")
  (prov-info		203 "Provisional Information")
  (no-content		204 "No Content")

  (mult-choice		300 "Multiple Choices")
  (moved-perm		301 "Moved Permanently")
  (moved-temp		302 "Moved Temporarily")
  (method		303 "Method (obsolete)")
  (not-mod		304 "Not Modified")

  (bad-request		400 "Bad Request")
  (unauthorized		401 "Unauthorized")
  (payment-req		402 "Payment Required")
  (forbidden		403 "Forbidden")
  (not-found		404 "Not Found")
  (method-not-allowed	405 "Method Not Allowed")
  (none-acceptable	406 "None Acceptable")
  (proxy-auth-required	407 "Proxy Authentication Required")
  (timeout		408 "Request Timeout")
  (conflict		409 "Conflict")
  (gone			410 "Gone")

  (internal-error	500 "Internal Server Error")
  (not-implemented	501 "Not Implemented")
  (bad-gateway		502 "Bad Gateway")
  (service-unavailable	503 "Service Unavailable")
  (gateway-timeout	504 "Gateway Timeout"))
	
(define (reply-code->text code)
  (cdr (assv code http-reply-text-table)))


;;; Text generation utilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  

(define (time->http-date-string time)
  (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))

;;; Output the first chunk of a reply header.

(define (begin-http-header out reply-code)
  (format out "~A ~d ~A\r~%"
	  server/protocol reply-code (reply-code->text reply-code))
  (format out "Date: ~A\r~%" (time->http-date-string (time)))
  (format out "Server: ~A\r~%" server/version))

(define (title-html out message new-protocol?)
  (if new-protocol? (write-crlf out))	; Separate html from headers.
  (format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
  (format out "<BODY>~%<H1>~A</H1>~%" message))


;;; (send-http-error-reply reply-code req options [message . extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Take an http-error condition, and format it into a reply to the client.
;;;
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
;;; even had a chance to parse and construct the request. This is only used
;;; for 400 BAD-REQUEST error report, and we make minimal assumptions in this 
;;; case (0.9 protocol for the reply, for example). I might be better off
;;; writing a special-case procedure for that case...

;;; SEND-HTTP-ERROR-REPLY is called from error handlers, so to avoid
;;; infinite looping, if an error occurs while it is running, we just
;;; silently return. (We no longer need to do this; I have changed 
;;; 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 options . args)
  (ignore-errors (lambda ()	; Ignore errors -- see note above.
		   (apply really-send-http-error-reply reply-code req options args))))

(define (really-send-http-error-reply reply-code req options . args)
  (http-log req reply-code)

  (let* ((message (if (pair? args) (car args)))
	 (extras  (if (pair? args) (cdr args) '()))

	 (new-protocol? (and req (not (v0.9-request? req)))) ; 1.0 or better?

	 ;; Is it OK to send back an HTML body explaining things?
	 (html-ok? (or (not req)
		       (not (string=? (request:method req) "HEAD"))))

	 (out (current-output-port))

	 (generic-title (lambda ()
			  (title-html out
				      (reply-code->text reply-code)
				      new-protocol?)))

	 (do-msg (lambda () (cond (message (display message out) (newline out))))))

    (if new-protocol? (begin-http-header out reply-code))

    ;; Don't output the blank line, as individual clauses might
    ;; want to add more headers.
    (if html-ok? (write-string "Content-type: text/html\r\n" out))

    ;; If html-ok?, we must send back some html, with the <body> tag unclosed.
    (cond

      ;; This error reply requires two args: message is the new URI: field,
      ;; and the first EXTRA is the older Location: field.
      ((or (= reply-code http-reply/moved-temp)
	   (= reply-code http-reply/moved-perm))
       (if new-protocol?
	   (begin
	     (format out "URI: ~A\r~%" message)
	     (format out "Location: ~A\r~%" (car extras))))
       (if html-ok?
	   (begin
	     (title-html out "Document moved" new-protocol?)
	     (format out
		     "This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
		     (if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
		     message))))

      ((= reply-code http-reply/bad-request)
       (if html-ok?
	   (begin
	     (generic-title)
	     (write-string "<P>Client sent a query that this server could not understand.\n"
			   out)
	     (if message (format out "<BR>~%Reason: ~A~%" message)))))

      ((= reply-code http-reply/unauthorized)
       (if new-protocol?
	   (format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
       (if html-ok?
	   (begin
	     (title-html out "Authorization Required" new-protocol?)
	     (write-string "<P>Browser not authentication-capable or\n" out)
	     (write-string "authentication failed.\n" out)
	     (if message (format out "~a~%" message)))))

      ((= reply-code http-reply/forbidden)
       (if (not html-ok?)
	   (begin
	     (title-html out "Request not allowed." new-protocol?)
	     (format out 
		     "Your client does not have permission to perform a ~A~%"
		     (request:method req))
	     (format out "operation on url ~a.~%" (request:uri req))
	     (if message (format out "<P>~%~a~%" message)))))
       
      ((= reply-code http-reply/not-found)
       (if html-ok?
	   (begin
	     (title-html out "URL not found" new-protocol?)
	     (write-string 
	      "<P>The requested URL was not found on this server.\n"
			   out)
	     (if message (format out "<P>~%~a~%" message)))))

      ((= reply-code http-reply/internal-error)
       (format (current-error-port) "ERROR: ~A~%" message)
       (http-syslog (syslog-level error) "internal-error: ~A" message)
       (if html-ok? 
	   (begin
	     (generic-title)
	     (format out "The server encountered an internal error or
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.~%"
		     (httpd-options-server-admin options))
	     (if message (format out "<P>~%~a~%" message)))))

      ((= reply-code http-reply/not-implemented)
       (if html-ok?
	   (begin
	     (generic-title)
	     (format out "This server does not currently implement 
the requested method (~A).~%"
		     (request:method req))
	     (if message (format out "<P>~a~%" message)))))

      (else (if html-ok? (generic-title))))

    (cond 
     (html-ok?
      ;; Output extra stuff and close the <body> tag.
      (for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
      (write-string "</BODY>\n" out)))
    ; (force-output out)  ;;; TODO check this
   ; (flush-all-ports)
    (force-output out)
;   (if bkp? (breakpoint "http error"))
    ))


;;; Return my Internet host name (my fully-qualified domain name).
;;; This works only if an actual resolver is behind host-info.
;;;
;;; On systems that do DNS via NIS/Yellow Pages, you only get an
;;; 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.


(define *fqdn-cache* #f)

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