;;; 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
  (make-response code message seconds mime extras body)
  response?
  (code response-code)
  (message response-message)
  (seconds response-seconds)
  (mime response-mime)
  (extras response-extras)
  (body response-body))

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

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

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

(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-syntax define-http-status-codes
  (syntax-rules ()
    ((define-http-status-codes table set (name val msg) ...)
     (begin (define table '((val . msg) ...))
	    (define-enum-constant set name val)
	    ...))))

(define-http-status-codes http-status-text-table http-status
  (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")
  
  (redirect             -301 "Internal redirect"))
	
(define (status-code->text code)
  (cdr (assv code http-status-text-table)))

;;; (make-http-error-response status-code req [message . extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Take an http-error condition, and format it into a response 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.

(define (make-http-error-response status-code req . args)
  (http-log req status-code)

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

	 (generic-title (lambda (port)
			  (title-html port
				      (status-code->text status-code))))
	 (send-message (lambda (port)
			 (if message 
			     (format port "<BR>~%Further Information: ~A<BR>~%" message))))
	 (close-html (lambda (port)
		       (for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
		       (write-string "</BODY>\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 <A HREF=\"~A\">new location</A>.~%"
		 (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 "<P>Client sent a query that this server could not understand.\n"
		       port)
	 (send-message port)
	 (close-html port))))

     ((= status-code http-status/unauthorized)
      (create-response
       (list (cons 'WWW-Authenticate message)) ; Vas is das? 
       ;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
       ;; message should be a challenge(?)
       (lambda (port options)
	 (title-html port "Authorization Required")
	 (write-string "<P>Browser not authentication-capable or\n" port)
	 (write-string "authentication failed.\n" port)
	 (send-message port)
	 (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))
	 (send-message port)
	 (close-html port))))
       
     ((= status-code http-status/not-found)
      (create-response
       '()
       (lambda (port options)
	 (title-html port "URL not found")
	 (write-string 
	  "<P>The requested URL was not found on this server.\n"
	  port)
	 (send-message port)
	 (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.
<P>
Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occured.~%"
		 (or (httpd-options-server-admin options)
		     "[no mail address available]"))
	 (send-message port)
	 (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))
	 (send-message port)
	 (close-html port))))

     ((= status-code http-status/bad-gateway)
      (create-response
       '()
       (lambda (port options)
	 (generic-title port)
	 (format port "An error occured while waiting for the 
response of a gateway.~%")
	 (send-message port)
	 (close-html port))))

     (else 
      (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code)
      (create-response
       '()
       (lambda (port options)
	 (generic-title port)
	 (send-message port)
	 (close-html port)))))))

(define (title-html out message)
  (format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
  (format out "<BODY>~%<H1>~A</H1>~%" message))

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


;; 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.
(define (make-redirect-response new-location)
  (make-response
   http-status/redirect
   (status-code->text http-status/redirect)
   (time)
   ""
   '()
   (make-redirect-body new-location)))