#! /bin/sh
exec /usr/local/bin/sizzle -s $0
!#
;; examples/webserver.scm -- 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.  

;; This is a simple webserver written in Scheme, running with the
;; Sizzle Scheme interpreter.  If you have install Sizzle in its
;; default location (/usr/local), you can fire it up by changing to
;; the directory the webserver.scm file is located in and typing
;; `./webserver.scm'.  Or, start it with 
;; `<path-of-sizzle-executable> -s webserver.scm'
;;
;; Below in the configuration section you can adjust some variables to
;; make this server suit your needs.

;; Configuration section =============================================

;; The IP port the webserver will listen on.
(define listening-port 8000)

;; The document root where the toplevel files will be looked for.
(define document-root "/home/mgrabmue/public_html/www/")

;; Set the directory where all source files for the web server can be found.
(define web-library-dir "./")

;; This is the directory where user servlets are loaded from.
(define user-library-dir "./")

;; The buffer size used for reading files.
(define buffer-size (* 4096 10))

;; Load some support code.
(load (string-append web-library-dir "http.scm"))
(load (string-append web-library-dir "fileaccess.scm"))

;; Regular expression stuff ==========================================

;; Dynamic URLs ======================================================

;; This is an example for a dynamic url handler.  It simply writes a
;; short message to its output port.
(define (test-handler in-port out-port method url headers)
  (send-success)
  (send-standard-header)
  (send-header "Connection" "close")
  (send-header "Content-Type" "text/html")
  (send-content
   (append '(
"<html>
<head>
<title>It worked</title>
</head>
<body>
<p>It seems that dynamic URL support in SizzWeb works.</p>
<p>The following headers were sent by your browser:</p><ul>")
(map (lambda (x) (string-append "<li>" (car x) ":" (cdr x) "</li>\n")) headers)
'("</ul></body>
</html>
")))
  (send-reply out-port))

;; This is the list of registered dynamic handlers.  The car of the
;; association is a string with the beginning of the strings the url
;; to handle must match, the cdr is the corresponding handler.
(define dynamic-url-handlers
  `(("/test" . ,test-handler)
    ("/bla" . ,test-handler)))

(define (add-dynamic-handler! url handler)
  (set! dynamic-url-handlers
	(cons (cons url handler) dynamic-url-handlers)))

;; Search the dynamic handler list for a handler for `url'.
;; Algorithm:
;; F1: Check if the list of handlers is exhausted. If yes, return false
;;     to caller and terminate.
;; F2: Check if the given url matches the head of `handlers'.
;;     If yes, return the handler and terminate.
;; F3: Goto F1.
(define (find-dynamic-handler url)
  (let loop ((handlers dynamic-url-handlers))
    (if (pair? handlers)
	(if (and (>= (string-length url) (string-length (caar handlers)))
	     (string=? (caar handlers)
		       (substring url 0 (string-length (caar handlers))))
	     (or (= (string-length url) (string-length (caar handlers)))
		 (char=? (string-ref url
				     (string-length (caar handlers)))
			 #\/)))
	    (car handlers)
	    (loop (cdr handlers)))
	#f)))

;; Try to invoke a dynamic handler on `url', if matching handler was found.
;; Return result of handler if found, return #f otherwise.
;; Algorithm:
;; E1: Search handler for `url'. If not found, goto E?
;; E2: Invoke the handler and terminate.
;; E3: Return false to caller and terminate.
(define (handle-dynamic-url in-port out-port method url headers)
  (let ((handler (find-dynamic-handler url)))
    (if handler
	((cdr handler) in-port out-port method url headers)
	#f)))

;; Method handlers ===================================================

;; Handle a GET request for the resource URL.
;; Algorithm:
;; C1: Read header lines from input port
;; C2: Try to execute dynamic url handler for given url
;; C3: If successful, terminate
;; C4: Check the passed url.  If file is not found, goto C7
;; C5: Check access permission.  If not granted, goto C8
;; C6: Send file to output port and terminate.
;; C7: Send `file not found' response and terminate.
;; C8: Send `access denied' response and terminate.
(define (handle-get-method in-port out-port method url)
  (let ((headers (read-headers in-port)))
    (if (not (handle-dynamic-url in-port out-port method url headers))
	(begin
	  (reset-protocol!)
	  (let ((filename (create-system-filename url)))
	    (if filename
		(if (access-forbidden? filename)
		    (send-forbidden out-port url)
		    (transmit-file filename out-port))
		(send-not-found out-port url)))))))

;; Handle an unknown method request.
;; Algorithm:
;; D1: Send `unknown message' response and terminate.
(define (handle-unknown-method in-port out-port method url)
  (send-unknown-method out-port method url))

;; Handle an unknown/erroneous request.
;; Algorithm:
;; E1: Send `bad request' response and terminate.
(define (handle-bad-request in-port out-port)
  (send-bad-request out-port))

;; Return a procedure for handling requests of method METHOD
;; Algorithm:
;; B1: Search method handler assoc list for handler for `method'
;; B2: If found, return handler procedure and terminate
;; B3: Return handler for `unknown method' response and terminate
(define (get-method-handler method)
  (let ((method-handlers
	 `(("GET" . ,handle-get-method))))
    (let ((handler (assoc method method-handlers)))
      (if handler
	  (cdr handler)
	  handle-unknown-method))))

;; Main program ======================================================

;; Read request from `in-port' and send response to `out-port'.
;; Algorithm:
;; A1: Read request line
;; A2: Parse request line, if not valid then goto A5
;; A3: Call the request handler for the request method
;; A4: terminate
;; A5: Send `bad request' response, goto A4
(define (handle-request in-port out-port)
  (let ((line (read-line in-port)))
;    (display line)
;    (newline)
    (let ((req (parse-request-line line)))
      (if req
	  ((get-method-handler (first req)) in-port out-port
	   (first req) (second req))
	  (handle-bad-request in-port out-port)))))

;; Everything initialized, now try to load user servlet code.
(catch 'file-not-found
       (lambda ()
	 (load (string-append user-library-dir "servlets.scm")))
       (lambda x #f))

;; HACK-ALERT: Install a signal handler for SIGPIPE, because otherwise
;; the server will sometimes crash.
(signal SIGPIPE (lambda (x) (exit)))
;; HACK-ALERT: Install a signal handler for SIGCHLD, because otherwise
;; zombies will hang around.
(signal SIGCHLD (lambda (x) (wait)))

;; Fork before handling the request.  This allows several requests to
;; be served in parallel.
(define (fork-and-handle in-port out-port)
  (let ((pid (fork)))
    (cond ((= pid 0)
	   (handle-request in-port out-port)
	   (exit))
	  ((> pid 0)
	   #t)
	  (else (throw 'fork-failed "Hm...")))))

;(handle-request (current-input-port) (current-output-port))
;(exit)
;; Kick off request handling.
(define server-port (server-socket listening-port))
(server-loop server-port fork-and-handle)
