;; examples/http.scm -- http module for the simple webserver
;;
;; Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;
;; This is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this package; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.  

(define server-name "SizzWeb 0.0.1")

;; Response wrapping =================================================

(define protocol-line #f)
(define header-lines "")
(define content '())

;; Discard all headers and data already being scheduled for sending.
(define (reset-protocol!)
  (set! protocol-line #f)
  (set! header-lines "")
  (set! content '()))

;; Schedule an HTTP error protocol line with error number NUMBER and
;; error message MSG for sending.
(define (send-error number msg)
  (set! protocol-line
	(string-append "HTTP/1.0 " (number->string number) " " msg "\r\n")))

;; Schedule an HTTP success protocol line for sending.
(define (send-success)
  (set! protocol-line "HTTP/1.0 200 OK\r\n"))

;; Schedule the header NAME with value VALUE for sending.
(define (send-header name value)
  (set! header-lines (string-append header-lines name ": " value "\r\n")))

;; Schedule the content CONT (which must be a list of strings) for
;; sending.
(define (send-content cont)
  (let ((cont-len 0))
    (for-each (lambda (x) (set! cont-len (+ cont-len (string-length x))))
	      cont)
    (send-header "Content-Length" (number->string cont-len))
    (set! content cont)))
	
;; Schedule a date header with the current date for sending.
(define (send-date)
  (let ((date (strftime "%a, %m %b %Y %H:%M:%S GMT" (gmtime (current-time)))))
    (send-header "Date" date)))

;; Schedule the server header for sending.
(define (send-server)
  (send-header "Server" server-name))

;; Schedule the date and server headers for sending.
(define (send-standard-header)
  (send-date)
  (send-server))

;; Send the reply constructed by a `send-error'/`send-success',
;; various `send-header' and a `send-content' call to port OUT-PORT.
(define (send-reply out-port)
  (send-header "XPad" "avoid browser bug")
;  (display protocol-line)
;  (display header-lines)
;  (newline)
;  (for-each (lambda (x) (display x)) content)
  (display protocol-line out-port)
  (display header-lines out-port)
  (display "\r\n" out-port)
  (for-each (lambda (x) (display x out-port)) content)
  (force-output out-port)
  (reset-protocol!))

;; Read the contents of the file called FILENAME into a list of
;; strings.  Return the resulting list.
(define (read-content filename)
  (let ((fd (open-fdes filename O_RDONLY))
	(cont '()))
    (let loop ((rd (sys:read fd buffer-size)))
      (if (> (u8vector-length rd) 0)
	  (begin
	    (set! cont (cons (u8vector->string rd) cont))
	    (loop (sys:read fd buffer-size)))
	  (begin
	    (close fd)
	    (reverse cont))))))

;; Parse a single header line.  Return the two values, the header name
;; and the value.
(define (parse-header-line line)
  (let ((colon-index (string-index line #\:)))
    (if colon-index
	(values (substring line 0 colon-index)
		(substring line (+ colon-index 1) (string-length line)))
	(values line ""))))

;; Read all Headers from IN-PORT and return an association list of the
;; headers.
(define (read-headers in-port)
  (let loop ((line (read-line in-port)) (accu '()))
;    (display "\"") (display line) (display "\"")
;    (newline)
    (if (or (eof-object? line) (string-null? (string-trim-both line)))
	(reverse accu)
	(receive (name value) (parse-header-line (string-trim-both line))
		 (loop (read-line in-port) (cons (cons name value) accu))))))

;; Work horses for sending responses =================================

;; Send a `Not Found' response to OUT-PORT.  URL is the resource which
;; could not be found.
(define (send-not-found out-port url)
  (send-error 404 "Not Found")
  (send-date)
  (send-header "Connection" "close")
  (send-header "Content-Type" "text/html")
  (send-content (list "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>404 Not Found</TITLE>
</HEAD><BODY>
<h2>404 Not Found</h2>
The requested URL " url " was not found on this server.<P>
<hr>
<address>"
server-name
"</address></BODY></HTML>
"))
  (send-reply out-port))

;; Send a `Bad Request' response to OUT-PORT.
(define (send-bad-request out-port)
  (send-error 400 "Bad Request")
  (send-standard-header)
  (send-header "Connection" "close")
  (send-header "Content-Type" "text/html")
  (send-content (list "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>400 Bad Request</TITLE>
</HEAD><BODY>
<h2>400 Bad Request</h2>
Your browser sent a request that
this server could not understand.<P>
<hr>
<address>"
server-name
"</address></BODY></HTML>
"))
  (send-reply out-port))

;; Send an `Unknown Method' response to OUT-PORT.
(define (send-unknown-method out-port method url)
  (send-error 501 "Unknown Method")
  (send-standard-header)
  (send-header "Connection" "close")
  (send-header "Content-Type" "text/html")
  (send-content (list "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>501 Method Not Implemented</TITLE>
</HEAD><BODY>
<h2>501 Method Not Implemented</h2>
" method " to " url " not supported.<P>
<hr>
<address>"
server-name
"</address></BODY></HTML>
"))
  (send-reply out-port))

;; Send an `Forbidden' response to OUT-PORT.
(define (send-forbidden out-port url)
  (send-error 400 "Forbidden")
  (send-standard-header)
  (send-header "Connection" "close")
  (send-header "Content-Type" "text/html")
  (send-content (list "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>403 Forbidden</TITLE>
</HEAD><BODY>
<h2>Access Forbidden</h2>
You do not have permission to access " url "<P>
<hr>
<address>"
server-name
"</address></BODY></HTML>
"))
  (send-reply out-port))

;; Transfer the file FILENAME to OUT-PORT, prepending the necessary
;; protocol stuff.
(define (transmit-file filename out-port)
  (send-success)
  (send-standard-header)
  (send-header "Connection" "close")
  (send-header "Content-Type" (get-content-type filename))
  (send-content (read-content filename))
  (send-reply out-port))

;; Helper procedures =================================================

;; Return a valid Content-Type string which matches FILENAME best
(define (get-content-type filename)
  (let ((lst (string-split #\. filename))
	(content-mapping
	 '(("mp2" . "audio/x-mpeg" )
	   ("mpa" . "audio/x-mpeg" )
	   ("abs" . "audio/x-mpeg" )
	   ("mpega" . "audio/x-mpeg" )
	   ("mpeg" . "video/mpeg" )
	   ("mpg" . "video/mpeg" )
	   ("mpe" . "video/mpeg" )
	   ("mpv" . "video/mpeg" )
	   ("vbs" . "video/mpeg" )
	   ("mpegv" . "video/mpeg" )
	   ("bin" . "application/octet-stream" )
	   ("com" . "application/octet-stream" )
	   ("dll" . "application/octet-stream" )
	   ("bmp" . "image/x-MS-bmp" )
	   ("exe" . "application/octet-stream" )
	   ("mid" . "audio/x-midi" )
	   ("midi" . "audio/x-midi" )
	   ("htm" . "text/html" )
	   ("html" . "text/html" )
	   ("txt" . "text/plain" )
	   ("gif" . "image/gif" )
	   ("tar" . "application/x-tar" )
	   ("jpg" . "image/jpeg" )
	   ("jpeg" . "image/jpeg" )
	   ("png" . "image/png" )
	   ("ra" . "audio/x-pn-realaudio" )
	   ("ram" . "audio/x-pn-realaudio" )
	   ("sys" . "application/octet-stream" )
	   ("wav" . "audio/x-wav" )
	   ("xbm" . "image/x-xbitmap" )
	   ("zip" . "application/x-zip" )
	   ("deb" . "application/x-debian-package" )
	   ("ps" . "application/postscript" ))))
    (if (pair? lst)
	(let ((ext (last lst)))
	  (let ((mapping (assoc ext content-mapping)))
	    (if mapping
		(cdr mapping)
		"application/octet-stream"))))))

;; The regular expression used for matching the first line of an HTTP
;; request.
(define request-regexp
  (make-regexp
   "^([^ \t]+)[ \t]+([^ \t]+)[ \t]*([^ \t]*)"))

;; Return the string which is at position IDX in the regexp match
;; result VEC.
(define (regexp-extract vec idx)
  (let ((start (car (vector-ref vec idx)))
	(end (cdr (vector-ref vec idx))))
    (substring (vector-ref vec 0) start end)))

;; Parse the request line REQ and return a list of the method, url and
;; HTTP version indicator, or #f if the request line was malformed.
(define (parse-request-line req)
  (let ((req-vec (regexp-exec request-regexp req)))
    (if (and req-vec (>= (vector-length req-vec) 4))
	(let ((method (regexp-extract req-vec 2))
	      (url (regexp-extract req-vec 3)))
	  (list method url (if (> (vector-length req-vec) 4)
			       (regexp-extract req-vec 4)
			       "HTTP/1.0")))
	#f)))