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

Last change on this file since 11983 was 11983, checked in by sjamaan, 13 years ago

Add feeble beginnings of the new spiffy implementation based on intarweb

File size: 9.5 KB
Line 
1;;
2;; Spiffy the web server
3;;
4; Copyright (c) 2007-2008, Peter Bex
5; Copyright (c) 2000-2005, Felix L. Winkelmann
6; All rights reserved.
7;
8; Redistribution and use in source and binary forms, with or without
9; modification, are permitted provided that the following conditions
10; are met:
11;
12; 1. Redistributions of source code must retain the above copyright
13;    notice, this list of conditions and the following disclaimer.
14; 2. Redistributions in binary form must reproduce the above copyright
15;    notice, this list of conditions and the following disclaimer in the
16;    documentation and/or other materials provided with the distribution.
17; 3. Neither the name of the author nor the names of its
18;    contributors may be used to endorse or promote products derived
19;    from this software without specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
26; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
27; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
28; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
30; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
32; OF THE POSSIBILITY OF SUCH DAMAGE.
33;
34; Please report bugs, suggestions and ideas to the Chicken Trac
35; ticket tracking system (assign tickets to user 'sjamaan'):
36; http://trac.callcc.org
37
38(module spiffy
39  (start-server with-headers send-status send-static-file
40                current-request current-response current-file current-pathinfo
41                current-hostname
42                root-path server-port index-files mime-type-map default-mime-type
43                handle-directory handle-not-found)
44
45(import chicken scheme extras ports files data-structures)
46(require-extension srfi-1 srfi-18 posix tcp
47                   intarweb uri-generic sendfile matchable)
48
49(define version 4)
50(define release 0)
51
52;;; Request processing information
53(define current-request  (make-parameter #f))
54(define current-response (make-parameter #f))
55(define current-file     (make-parameter #f))
56(define current-pathinfo (make-parameter #f))
57(define current-hostname (make-parameter #f))
58
59;;; Configuration
60(define root-path        (make-parameter "./web"))
61(define server-port      (make-parameter 8080))
62(define index-files      (make-parameter '("index.html" "index.htm")))
63(define mime-type-map
64  (make-parameter
65   '(("txt" . text/plain)
66     ("xml" . text/xml)
67     ("xul" . application/vnd.mozilla.xul+xml)
68     ("htm" . text/html)
69     ("html" . text/html)
70     ("js"  . text/javascript)
71     ("pdf" . application/pdf)
72     ("css" . text/css)
73     ("bmp" . image/bmp)
74     ("ico" . image/x-icon)
75     ("gif" . image/gif)
76     ("jpg" . image/jpeg)
77     ("jpeg" . image/jpeg)
78     ("png" . image/png))))
79(define default-mime-type (make-parameter 'application/octet-stream))
80
81;;; Custom handlers
82(define handle-directory
83  (make-parameter
84   (lambda (path)
85     (send-status 403 "Forbidden"))))
86(define handle-file
87  (make-parameter
88   (lambda (path)
89     (with-headers `((content-type ,(extension->mime-type
90                                     (pathname-extension path))))
91       (lambda ()
92         (send-static-file path))))))
93(define handle-not-found
94  (make-parameter
95   (lambda ()
96     (send-status 404 "Not found"
97                  "The resource you requested could not be found"))))
98
99
100(define (send-status code reason #!optional text)
101  (parameterize ((current-response (update-response (current-response)
102                                                    code: code
103                                                    reason: reason)))
104    (write-response (current-response))
105    (with-output-to-port (response-port (current-response))
106      (lambda ()
107        (print "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
108        (print "<!DOCTYPE html")
109        (print "  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"")
110        (print "         \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
111        (print "<html xmlns=\"http://www.w3.org/1999/xhtml\" ")
112        (print "      xml:lang=\"en\" lang=\"en\">")
113        (print "  <head>")
114        (printf "    <title>~A - ~A</title>\n" code reason)
115        (print "  </head>")
116        (print "  <body>")
117        (printf "    <h1>~A - ~A</h1>\n" code reason)
118        (if text (printf "    <p>~A</p>" text))
119        (print "  </body>")
120        (print "</html>")))))
121
122(define (send-static-file filename)
123  (with-headers `((content-length ,(file-size filename)))
124    (lambda ()
125      (write-response (current-response))
126      (let ([fd (file-open filename (+ open/binary open/rdonly))])
127              (handle-exceptions exn (begin
128                                       (file-close fd)
129                                       (signal exn))
130                (sendfile fd (response-port (current-response))))
131              (file-close fd)))))
132
133;; Determine the vhost to use. This tries to use the Host: header first
134;; and it it's not there, falls back to try to determine the vhost
135;; from host in the request line's URI, if any.
136;; In >= HTTP/1.1, a Host line is required, as per section 14.23 of RFC 2616
137;; It returns the empty string for HTTP/1.0, which is a bit of a hack but
138;; makes host regex matching less complicated.
139(define (determine-vhost)
140  (let ((host/port (header-value 'host (request-headers (current-request)) #f)))
141    (if host/port
142        (car host/port)
143        (if (and (= (request-major (current-request)) 1)
144                 (>= (request-minor (current-request)) 1))
145            #f
146            (or (uri-host (request-uri (current-request))) "")))))
147
148(define (extension->mime-type ext)
149  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
150
151(define (default-file-handler file)
152  (fprintf (response-port (current-response)) "GOT FILE ~A\n" file))
153
154(define (with-headers new-headers thunk)
155  (parameterize ((current-response
156                  (update-response
157                   (current-response)
158                   headers: (headers new-headers
159                                     (response-headers (current-response))))))
160    (thunk)))
161
162(define (process-directory path)
163  (let ((index-page (find (lambda (ip)
164                            (file-exists?
165                             (make-pathname (list (root-path) path) ip)))
166                          (index-files))))
167    (if index-page
168        (process-entry (make-pathname path index-page) '())
169        ((handle-directory) path))))
170
171;; If an URL is missing a trailing slash, instead of directly serving
172;; its index-file, redirect to the URL _with_ trailing slash.  This
173;; prevents problems with relative references since the directory
174;; would be seen as the file component in the path and get replaced.
175(define (redirect-directory-root path)
176  (let* ((newloc (make-pathname path "/"))
177         (url (uri-relative-to (uri-reference newloc)
178                               (request-uri (current-request)))))
179    (with-headers `((location ,url))
180      (lambda () (send-status 301 "Moved permanently")))))
181
182(define (process-entry current-path remaining-path)
183  (let ((path (make-pathname (root-path) current-path)))
184    (cond
185     ;; Check if there's a registered URI-handler first
186     ((directory? path)
187      (match remaining-path
188       (()    (redirect-directory-root current-path))
189       (("/") (process-directory current-path))
190       (else  (process-entry (make-pathname current-path (car remaining-path))
191                             (cdr remaining-path)))))
192     ((file-exists? path)
193      ((handle-file) path))
194     (else ((handle-not-found))))))
195
196(define (handle-incoming-request in out)
197  (parameterize ((current-request (read-request in))
198                 (current-response
199                  (make-response port: out
200                                 headers: (headers
201                                           `((content-type text/html))))))
202    (let* ((host (determine-vhost))
203           (path (uri-path (request-uri (current-request)))))
204      (if (and host (pair? path))
205          (parameterize ((current-hostname host)
206                         ;; Ensure the request URI includes host and scheme
207                         ;; Perhaps the intarweb egg should do this
208                         (current-request
209                          (update-request
210                           (current-request)
211                           uri: (uri-relative-to
212                                 (request-uri (current-request))
213                                 (absolute-uri (string-append "http://" host)))))) ; XXX
214            (process-entry (car path) (cdr path)))
215          ;; No host in the request? That's an error.
216          (send-status 400 "Bad request"
217                       "Your client sent a request that the server did not understand"))
218      ;; For now, just close the ports and allow the thread to exit
219      (close-output-port out)
220      (close-input-port in))))
221
222(define (start-server #!key (port (server-port)))
223  (letrec ((listener (tcp-listen port))
224           (accept-loop (lambda ()
225                          (receive (in out)
226                            (tcp-accept listener)
227                            (thread-start!
228                             (make-thread (lambda ()
229                                            (handle-incoming-request in out))))
230                            (accept-loop)))))
231    (accept-loop)))
232
233)
Note: See TracBrowser for help on using the repository browser.