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

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

Fix the way entries are processed. Start in rootdir with empty path string

File size: 9.4 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(define (extension->mime-type ext)
134  (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))
135
136(define (with-headers new-headers thunk)
137  (parameterize ((current-response
138                  (update-response
139                   (current-response)
140                   headers: (headers new-headers
141                                     (response-headers (current-response))))))
142    (thunk)))
143
144(define (process-directory path)
145  (let ((index-page (find (lambda (ip)
146                            (file-exists?
147                             (make-pathname (list (root-path) path) ip)))
148                          (index-files))))
149    (if index-page
150        (process-entry (make-pathname path index-page) '())
151        ((handle-directory) path))))
152
153;; If an URL is missing a trailing slash, instead of directly serving
154;; its index-file, redirect to the URL _with_ trailing slash.  This
155;; prevents problems with relative references since the directory
156;; would be seen as the file component in the path and get replaced.
157(define (redirect-directory-root path)
158  (let* ((newloc (make-pathname path "/"))
159         (url (uri-relative-to (uri-reference newloc)
160                               (request-uri (current-request)))))
161    (with-headers `((location ,url))
162      (lambda () (send-status 301 "Moved permanently")))))
163
164(define (process-entry current-path remaining-path)
165  (let ((path (make-pathname (root-path) current-path)))
166    (cond
167     ;; TODO Check if there's a registered URI-handler first
168     ((directory? path)
169      (match remaining-path
170       (()    (redirect-directory-root current-path))
171       (("/") (process-directory current-path))
172       (else  (process-entry (make-pathname current-path (car remaining-path))
173                             (cdr remaining-path)))))
174     ((file-exists? path)
175      ((handle-file) path))
176     (else ((handle-not-found))))))
177
178;; Determine the vhost to use. This tries to use the Host: header first
179;; and if it's not there, falls back to try to determine the vhost
180;; from host in the request line's URI, if any.
181;; In HTTP >= 1.1, a Host line is required, as per section 14.23 of RFC 2616.
182;; It returns the empty string for HTTP/1.0, which is a bit of a hack but
183;; makes host regex matching less complicated.
184(define (determine-vhost)
185  (let ((host/port (header-value 'host (request-headers (current-request)) #f)))
186    (if host/port
187        (car host/port)
188        (if (and (= (request-major (current-request)) 1)
189                 (>= (request-minor (current-request)) 1))
190            #f
191            (or (uri-host (request-uri (current-request))) "")))))
192
193(define (handle-incoming-request in out)
194  (parameterize ((current-request (read-request in))
195                 (current-response
196                  (make-response port: out
197                                 headers: (headers
198                                           `((content-type text/html))))))
199    (let* ((host (determine-vhost))
200           (path (uri-path (request-uri (current-request)))))
201      (if (and host (pair? path))
202          (parameterize ((current-hostname host)
203                         ;; Ensure the request URI includes host and scheme
204                         ;; Perhaps the intarweb egg should do this
205                         (current-request
206                          (update-request
207                           (current-request)
208                           uri: (uri-relative-to
209                                 (request-uri (current-request))
210                                 (absolute-uri (string-append "http://" host)))))) ; XXX
211            (process-entry "" path))
212          ;; No host in the request? That's an error.
213          (send-status 400 "Bad request"
214                       "Your client sent a request that the server did not understand"))
215      ;; For now, just close the ports and allow the thread to exit
216      (close-output-port out)
217      (close-input-port in))))
218
219(define (start-server #!key (port (server-port)))
220  (letrec ((listener (tcp-listen port))
221           (accept-loop (lambda ()
222                          (receive (in out)
223                            (tcp-accept listener)
224                            (thread-start!
225                             (make-thread (lambda ()
226                                            (handle-incoming-request in out))))
227                            (accept-loop)))))
228    (accept-loop)))
229
230)
Note: See TracBrowser for help on using the repository browser.