sunet/scheme/httpd/response.scm

;;; This file is part of the Scheme Untergrund Networking package.

;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

(define-record-type http-response :http-response
  (make-response code message seconds mime extras body)
  response?
  (code response-code) ;;HTTP status code
  (message response-message);;reason phrase: textual description of
			    ;;status-code, or #f (-> server sends
			    ;;default reason phrase)
  (seconds response-seconds);;time the content was created
  (mime response-mime);;string indicating the MIME type of the response
  (extras response-extras);;assoc list with extra headers to be
			  ;;added to the response; its elements are
			  ;;pairs, each of which consists of a symbol
			  ;;representing the field name and a string
			  ;;representing the field value.
  (body response-body));; message-body

;;TODO: mime shouldn't be a field in http-response, because it needn't be present for
;;responses which don't include a message-body.
;;Instead treat mime-type like any other header.
;;(Not urgent, as RFC 2616 doesn't prohibit presence of Content-Type header field 
;;in body-less responses).

;; This is mainly for nph-... CGI scripts.
;; This means that the body will output the entire MIME message, not
;; just the part after the headers.

(define-record-type http-nph-response :http-nph-response
  (make-nph-response body)
  nph-response?
  (body nph-response-body))

(define-record-type http-input-response :http-input-response
  (make-input-response body-maker)
  input-response?
  (body-maker input-response-body-maker))

(define-record-type http-writer-body :http-writer-body
  (make-writer-body proc)
  writer-body?
  (proc writer-body-proc))

(define-record-type http-reader-writer-body :http-reader-writer-body
  (make-reader-writer-body proc)
  reader-writer-body?
  (proc reader-writer-body-proc))

(define-record-type http-redirect-body :http-redirect-body
  (make-redirect-body location)
  redirect-body?
  (location redirect-body-location))

;; type for responses which MUST NOT include a body (101, 204, 304)
(define-enumerated-type no-body :no-body
  no-body?
  no-body-elements
  no-body-name
  no-body-index
  (none))

(define (display-http-body body iport oport options)
  (cond
   ((writer-body? body)
    ((writer-body-proc body) oport options))
   ((reader-writer-body? body)
    ((reader-writer-body-proc body) iport oport options))))

(define-finite-type status-code :http-status-code
  (number message)
  status-code?
  status-codes
  status-code-name
  status-code-index
  (number status-code-number)
  (message status-code-message)
  (
   (continue		100 "Continue")
   (switch-protocol	101 "Switching Protocols")

   (ok			200 "OK")
   (created		201 "Created")
   (accepted		202 "Accepted")
   (non-author-info	203 "Non-Authoritative Information")
   (no-content		204 "No Content")
   (reset-content	205 "Reset Content")
   (partial-content	206 "Partial Content")

   (mult-choice		300 "Multiple Choices")
   (moved-perm		301 "Moved Permanently")
   (found		302 "Found");;use 303 or 307 for unambiguity;
				    ;;use 302 for compatibility with
				    ;;pre-1.1-clients
   (see-other		303 "See other");;client is expected to
					;;perform a GET on new URI
   (not-mod		304 "Not Modified")
   (use-proxy		305 "Use Proxy")
   (temp-redirect	307 "Temporary Redirect");;analogous to "302
						 ;;Moved Temporarily"
						 ;;in RFC1945

   (bad-request		400 "Bad Request")
   (unauthorized	401 "Unauthorized")
   (payment-required	402 "Payment Required")
   (forbidden		403 "Forbidden")
   (not-found		404 "Not Found")
   (method-not-allowed	405 "Method Not Allowed")
   (not-acceptable	406 "Not Acceptable")
   (proxy-auth-required	407 "Proxy Authentication Required")
   (timeout		408 "Request Timeout")
   (conflict		409 "Conflict")
   (gone		410 "Gone")
   (length-required	411 "Length Required")
   (precon-failed	412 "Precondition Failed")
   (req-ent-too-large	413 "Request Entity Too Large")
   (req-uri-too-large	414 "Request URI Too Large")
   (unsupp-media-type	415 "Unsupported Media Type")
   (req-range-not-sat	416 "Requested Range Not Satisfiable")
   (expectation-failed	417 "Expectation Failed")

   (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")
   (version-not-supp	505 "HTTP Version Not Supported")  

   (redirect             -301 "Internal redirect")))

(define (name->status-code name)
  (if (not (symbol? name))
      (call-error name->status-code (list name))
      (let loop ((i 0))
	(cond ((= i (vector-length status-codes))
	       #f)
	      ((eq? name
		    (status-code-name (vector-ref status-codes i)))
	       (vector-ref status-codes i))
	      (else
	       (loop (+ i 1)))))))

(define (number->status-code number)
  (if (not (number? number))
      (call-error number->status-code (list number))
      (let loop ((i 0))
	(cond ((= i (vector-length status-codes))
	       #f)
	      ((= number
		  (status-code-number (vector-ref status-codes i)))
	       (vector-ref status-codes i))
	      (else
	       (loop (+ i 1)))))))
	
;;; (make-error-response status-code req [extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 can be the case for 
;;; internal-error, bad-request, (possibly bad-gateway and ...?)


(define (make-error-response code req . extras)
  (let*
      ;;catch server internal errors coming off by calls of make-error-response with too few arguments
      ((assert (lambda (n) 
		 (if (< (length extras) n)
		     (make-error-response (status-code internal-error) req
				 "Too few arguments to make-error-response"))))
       (generic-title (lambda (port)
			(title-html port
				    (status-code-message code))))
       (close-html (lambda (port args)
		     (if (not (null? args))
			 (format port "<br/>~%Further Information:~%"))
		     (for-each (lambda (x) (format port "<br/>~%~s~%" x)) args)
		     (format port "</p>~%</body>~%</html>~%")))
       		
       (create-response
	(lambda (headers body)
	  (make-response code
			 #f
			 (time)
			 "text/html"
			 headers
			 body)))

       (create-writer-body-response
	(lambda (headers writer-proc)
	  (create-response headers (make-writer-body writer-proc))))

       (create-no-body-response
	(lambda (headers)
	  (create-response headers (no-body none)))))

    (cond

     ;;this response requires one arg:
     ;;the value of the Upgrade field header,
     ;;which must be a string listing the protocols which are being switched
     ;;for example "HTTP/2.0, IRC/6.9"
     ((eq? code (status-code switch-protocol));; server currently doesn't have ability to switch protocols
      (assert 1)
      (create-no-body-response
       (list (cons 'upgrade (car extras))
	     (cons 'connection "upgrade")))) ;; need this, because Upgrade header field only applies to immediate connection
      
     ((eq? code (status-code no-content))
      (create-no-body-response '()))

     ;; This error response requires one arg:
     ;; the value of the Location field header,
     ;; which must be a single absolute URI
     ((or (eq? code (status-code found));302
	  (eq? code (status-code see-other));303
	  (eq? code (status-code temp-redirect));307
	  (eq? code (status-code moved-perm)));301
      (assert 1)
      (create-writer-body-response
       (list (cons 'location (car extras)))
       (lambda (port options)
	 (title-html port "Document moved")
	 (format port
		 "The requested resource has moved ~A to a <a href=\"~A\">new location</a>.~%"
		 (if (eq? code (status-code moved-perm))
		     "permanently"
		     "temporarily")
		 (car extras))
	 (close-html port (cdr extras)))))

     ((eq? code (status-code not-mod))
      (create-no-body-response '())) ;;see RCF 2616 10.3.5: this is only a valid answer if the server never sends
                                     ;;any of the headers Expires, Cache-Control, Vary for this resource

     ((eq? code (status-code bad-request)) 
      (create-writer-body-response 
       '()
       (lambda (port options) 
	 (generic-title port) 
	 (format port "The request the client sent could not be understood by this server due to malformed syntax.~% Report to client maintainer.~%")
	 (close-html port extras))))

     ;; This error response requires one arg:
     ;; the value of the Allow field header,
     ;; which must be a string listing the valid methods for the requested resource
     ;; Ex.: "GET, HEAD, POST"
     ((eq? code (status-code method-not-allowed))
      (assert 1)
      (create-writer-body-response
       (list (cons 'allow (car extras)))
       (lambda (port options)
	 (generic-title port)
	 (format port "The method ~A is not allowed on the requested resource ~A.~%" 
		 (request-method req) (http-url->url-string (request-url req)))
	 (close-html port (cdr extras)))))

     ;; This error response requires one arg:
     ;; the value of the WWW-Authenticate header field,
     ;; which must be a challenge (as described in RFC 2617)
     ((eq? code (status-code unauthorized))
      (assert 1)
      (create-writer-body-response
       (list (cons 'WWW-Authenticate (car extras))) 
       (lambda (port options)
	 (title-html port "Authentication Required")
	 (format port "Client not authentication-capable or authentication failed.~%")
	 (close-html port (cdr extras)))))

     ((eq? code (status-code forbidden))
      (create-writer-body-response
       '()
       (lambda (port options)
	 (title-html port "Request not allowed.")
	 (format port "The request the client sent is not allowed.~% Retrying won't help.~%")
	 (close-html port extras))))
       
     ((eq? code (status-code not-found))
      (create-writer-body-response
       '()
       (lambda (port options)
	 (title-html port "Resource not found")
	 (format port "The requested resource ~A was not found on this server.~%" 
		 (http-url->url-string (request-url req)))
	 (close-html port extras))))

     ((eq? code (status-code internal-error))
      (create-writer-body-response
       '()
       (lambda (port options)
	 (generic-title port)
	 (format port "This server encountered an internal error or misconfiguration and was unable to complete your request.~%<br/>~%Please inform the server administrator ~A of the circumstances leading to the error, and the time it occured.~%"
		 (or (httpd-options-server-admin options)
		     "[no mail address available]"))
	 (close-html port extras))))

     ((eq? code (status-code not-implemented))
      (create-writer-body-response
       '()
       (lambda (port options)
	 (generic-title port)
	 (format port "This server does not recognize or does not implement the requested method ~A.~%"
		 (request-method req))
	 (close-html port extras))))

     ((eq? code (status-code bad-gateway))
      (create-writer-body-response
       '()
       (lambda (port options)
	 (generic-title port)
	 (format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
	 (close-html port extras)))))))

  
(define (title-html out message)
  ;;produce valid XHTML 1.0 Strict
  (emit-prolog out)
  (emit-tag out 'html xmlnsdecl-attr)
  (format out "~%<head>~%<title>~%~A~%</title>~%</head>~%" message)
  (format out "<body>~%<h1>~A</h1>~%<p>~%" message))

;; Creates a redirect response. The server will serve the new file
;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and
;; begin with a slash.  This is intended for CGI scripts. Note that
;; the browser won't notice the redirect. Thus, it will keep the
;; original URL. For "real" redirections, use 
;; (make-error-response (status-code moved-perm) req 
;;                      "new-location").
(define (make-redirect-response new-location)
  (make-response
   (status-code redirect)
   #f
   (time)
   ""
   '()
   (make-redirect-body new-location)))