source: project/release/4/spiffy/trunk/spiffy.scm @ 12024

;;
;; Spiffy the web server
;;
; Copyright (c) 2007-2008, Peter Bex
; Copyright (c) 2000-2005, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of the author nor the names of its
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.
;
; Please report bugs, suggestions and ideas to the Chicken Trac
; ticket tracking system (assign tickets to user 'sjamaan'):
; http://trac.callcc.org

(module spiffy
  (start-server with-headers send-status send-static-file
   current-request current-response current-file current-pathinfo
   root-path server-port index-files mime-type-map default-mime-type default-host
   handle-directory handle-not-found
   restart-request)

(import chicken scheme extras ports files data-structures)
(require-extension srfi-1 srfi-18 posix tcp
                   intarweb uri-generic sendfile matchable)

(define version 4)
(define release 0)

;;; Request processing information
(define current-request  (make-parameter #f))
(define current-response (make-parameter #f))
(define current-file     (make-parameter #f))
(define current-pathinfo (make-parameter #f))

;;; Configuration
(define root-path        (make-parameter "./web"))
(define server-port      (make-parameter 8080))
(define index-files      (make-parameter '("index.html" "index.htm")))
(define mime-type-map
  (make-parameter
   '(("txt" . text/plain)
     ("xml" . text/xml)
     ("xul" . application/vnd.mozilla.xul+xml)
     ("htm" . text/html)
     ("html" . text/html)
     ("js"  . text/javascript)
     ("pdf" . application/pdf)
     ("css" . text/css)
     ("bmp" . image/bmp)
     ("ico" . image/x-icon)
     ("gif" . image/gif)
     ("jpg" . image/jpeg)
     ("jpeg" . image/jpeg)
     ("png" . image/png))))
(define default-mime-type (make-parameter 'application/octet-stream))
(define default-host (make-parameter "localhost")) ;; XXX Can we do without?

;;; Custom handlers
(define handle-directory
  (make-parameter
   (lambda (path)
     (send-status 403 "Forbidden"))))
(define handle-file
  (make-parameter
   (lambda (path)
     (with-headers `((content-type ,(extension->mime-type
                                     (pathname-extension path))))
       (lambda ()
         (send-static-file path))))))
(define handle-not-found
  (make-parameter
   (lambda ()
     (send-status 404 "Not found"
                  "The resource you requested could not be found"))))


;;; Internal parameters
(define request-restarter (make-parameter #f))

;; A simple utility procedure to render a status code with message
(define (send-status code reason #!optional text)
  (parameterize ((current-response (update-response (current-response)
                                                    code: code
                                                    reason: reason)))
    (write-response (current-response))
    (with-output-to-port (response-port (current-response))
      (lambda ()
        (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
        (print "<!DOCTYPE html")
        (print "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
        (print "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
        (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ")
        (print "      xml:lang=\"en\" lang=\"en\">")
        (print "  <head>")
        (printf "    <title>~A - ~A</title>\n" code reason)
        (print "  </head>")
        (print "  <body>")
        (printf "    <h1>~A - ~A</h1>\n" code reason)
        (if text (printf "    <p>~A</p>" text))
        (print "  </body>")
        (print "</html>")))))

(define (send-static-file filename)
  (let ((path (make-pathname (root-path) filename)))
    (with-headers `((content-length ,(file-size path)))
      (lambda ()
        (write-response (current-response))
        (let ([fd (file-open path (+ open/binary open/rdonly))])
          (handle-exceptions exn (begin
                                   (file-close fd)
                                   (signal exn))
                             (sendfile fd (response-port (current-response))))
          (file-close fd))))))

(define (extension->mime-type ext)
  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))

(define (with-headers new-headers thunk)
  (parameterize ((current-response
                  (update-response
                   (current-response)
                   headers: (headers new-headers
                                     (response-headers (current-response))))))
    (thunk)))

(define (process-directory path)
  (let ((index-page (find (lambda (ip)
                            (file-exists?
                             (make-pathname (list (root-path) path) ip)))
                          (index-files))))
    (if index-page
        (process-entry (make-pathname path index-page) '())
        ((handle-directory) path))))

;; If an URL is missing a trailing slash, instead of directly serving
;; its index-file, redirect to the URL _with_ trailing slash.  This
;; prevents problems with relative references since the directory
;; would be seen as the file component in the path and get replaced.
(define (redirect-directory-root path)
  (let* ((newloc (make-pathname path "/"))
         (url (uri-relative-to (uri-reference newloc)
                               (request-uri (current-request)))))
    (with-headers `((location ,url))
      (lambda () (send-status 301 "Moved permanently")))))

(define (process-entry current-path remaining-path)
  (let ((path (make-pathname (root-path) current-path)))
    (cond
     ;; TODO Check if there's a registered URI-handler first
     ((directory? path)
      (match remaining-path
       (()    (redirect-directory-root current-path))
       (("/") (process-directory current-path))
       (else  (process-entry (make-pathname current-path (car remaining-path))
                             (cdr remaining-path)))))
     ((file-exists? path)
      ((handle-file) current-path))
     (else ((handle-not-found))))))

;; Determine the vhost and port to use. This follows RFC 2616, section 5.2:
;; If request URL is absolute, use that.  Otherwise, look at the Host header.
;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of
;; RFC 2616.  If no host line is present, it returns the default host
;; for HTTP/1.0.
(define (determine-vhost/port)
  (let* ((request-uri (request-uri (current-request)))
         (request-host (uri-host request-uri))
         (host-header (header-value 'host (request-headers (current-request)))))
    (if request-host
        (values request-host (or (uri-port request-uri) 80))
        (if host-header
            (values (car host-header) (cdr host-header))
            (if (and (= (request-major (current-request)) 1)
                     (>= (request-minor (current-request)) 1))
                (values #f #f)
                (values (default-host) 80))))))

(define (normalize-current-request-uri)
  (receive (host port) (determine-vhost/port)
    (if host
        (update-request (current-request)
                        uri: (uri-relative-to
                              (request-uri (current-request))
                              ;; XXX
                              (absolute-uri (conc "http://" host ":" port))))
        (current-request))))

(define (restart-request req)
  ((request-restarter) req (request-restarter)))

(define (handle-incoming-request in out)
  (parameterize ((current-request (read-request in))
                 (current-response
                  (make-response port: out
                                 headers: (headers
                                           `((content-type text/html))))))
    (let ((path (uri-path (request-uri (current-request)))))
      (receive (req cont)
        (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
        (parameterize ((current-request req)
                       (request-restarter cont))
          (if (and (uri-host (request-uri (current-request))) (pair? path))
              (process-entry "" path)
              ;; No host in the request? That's an error.
              (send-status 400 "Bad request"
                           "Your client sent a request that the server did not understand"))))
      ;; For now, just close the ports and allow the thread to exit
      (close-output-port out)
      (close-input-port in))))

(define (start-server #!key (port (server-port)))
  (letrec ((listener (tcp-listen port))
           (accept-loop (lambda ()
                          (receive (in out)
                            (tcp-accept listener)
                            (thread-start!
                             (make-thread (lambda ()
                                            (handle-incoming-request in out))))
                            (accept-loop)))))
    (accept-loop)))

)