source: project/release/3/web-unity/trunk/web-unity.scm @ 10859

Last change on this file since 10859 was 10859, checked in by sjamaan, 12 years ago

Forgot to define wu:cookies variable

File size: 6.6 KB
Line 
1;;;; web-unity.scm
2;
3; Copyright (c) 2007, Peter Bex
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26;; Ensure we load all extensions needed here, even if only
27;; a few subsystems need it so there are no unexpected
28;; environment differences between unity subsystems.
29;; Look into if/how this can be done using EXPORT etc.
30(use regex-case http-utils posix)
31
32(define wu:params (make-parameter #f))
33(define wu:cookies (make-parameter #f))
34(define wu:query-params (make-parameter #f))
35(define wu:path-info (make-parameter #f))
36(define wu:script-name (make-parameter #f))
37(define wu:script-filename (make-parameter #f))
38(define wu:request-method (make-parameter #f))
39(define wu:response-headers (make-parameter #f))
40(define wu:response-code (make-parameter '(200 . "OK")))
41(define wu:headers-sent (make-parameter #f))
42
43;; Basically copied from Spiffy
44(define generate-error-message
45  (let ()
46    (define exn-message (condition-property-accessor 'exn 'message "(no message)"))
47    (define exn-location (condition-property-accessor 'exn 'location "(unknown location)"))
48    (define exn-arguments (condition-property-accessor 'exn 'arguments '()))
49    (define exn? (condition-predicate 'exn))
50    (lambda (exn)
51      (let ((chain (with-output-to-string print-call-chain)))
52        (with-output-to-string
53          (lambda ()
54            (if (exn? exn)
55                (begin
56                  (display "<h2>Error:")
57                  (and-let* ([loc (exn-location exn)])
58                            (printf " (<em>~A</em>)" (htmlize (->string loc))))
59                  (printf "</h2><h3>~A</h3>" (htmlize (exn-message exn)))
60                  (unless (null? (exn-arguments exn))
61                          (printf "<ul>")
62                          (for-each
63                           (lambda (a)
64                             (##sys#with-print-length-limit 120 (lambda () (printf "<li>~S</li>" (htmlize (->string a))))))
65                           (exn-arguments exn))
66                          (printf "</ul>"))
67                  (printf "<pre>~a</pre>" (htmlize chain)))
68                (begin
69                  (##sys#with-print-length-limit
70                   120
71                   (lambda ()
72                     (printf "<hr /><strong>Uncaught exception:</strong> ~S" exn)))))))))))
73
74(define wu:exception-handler
75  (make-parameter (lambda (exn)
76                    (printf
77                     "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"><html lang=\"en\"><head><title>Error!</title></head><body><h3>Sorry, your request could not be handled.</h3>~A</body></html>"
78                     (generate-error-message exn)))))
79
80(define (wu:invoke-dispatcher dispatcher)
81  (parameterize ((wu:headers-sent #f)
82                 (wu:cookies (get-request-cookies)))
83   (handle-exceptions exn (begin (unless (wu:headers-sent)
84                                         (parameterize ((wu:response-code '(500 . "Internal server error")))
85                                           (wu:write-headers)))
86                                 ((wu:exception-handler) exn))
87                      (dispatcher))))
88
89(load-verbose #f)  ;; No "loading xyz.scm..." in output
90
91; Add http/1.1 chunking to an existing output port
92(define (wu:chunked-output-port p)
93  (make-output-port
94   (lambda (data)
95     (fprintf p "~X\r\n~A\r\n" (string-length data) data))
96   void))
97
98;; From Spiffy
99(define (wu:single-header? name)
100  (not (member name '("Set-Cookie") string-ci=?)))
101
102(define (wu:set-header! name value)
103  (if (wu:single-header? name)
104      (let* ([rh (wu:response-headers)]
105             [a (assoc name rh string-ci=?)] )
106        (if a
107            (set-cdr! a value)
108            (wu:response-headers (alist-cons name value rh)) ) )
109      (wu:response-headers (alist-cons name value (wu:response-headers)))))
110
111;;; Cookie procedures taken from spiffy-utils and ported to WU
112(define (wu:cookie-set! name value . args)
113  (let ((conc-cond (lambda (s1 s2 s3) (if s2 (conc s1 s2 s3) ""))))
114    (let-optionals args ((comment #f) (max-age #f) (domain #f) (path #f)
115                         (secure #f))
116                   (wu:set-header! "Set-Cookie"
117                    (string-append (->string name) "=\"" (->string value) "\""
118                                   (conc-cond "; Comment=\"" comment "\"")
119                                   (conc-cond "; Max-Age=\"" max-age "\"")
120                                   (conc-cond "; Domain=\"" domain "\"")
121                                   (conc-cond "; Path=\"" path "\"")
122                                   (if secure "; Secure" "")
123                                   "; Version=1")))))
124
125;;; Delete a cookie by settings its maximum age to 0 seconds
126(define (wu:cookie-delete! name . args)
127  (let-optionals args ((domain #f) (path #f))
128    (wu:cookie-set! (->string name) "" #f 0 domain path)))
129
130; Get "cookie variable" value
131; TODO: Implement cookie handling better we can get a cookie's Path/Domain
132;        and make the `$Version' cookie disappear to the user.
133(define (get-request-cookies)
134  (let ((cookie-hdr (wu:get-header "cookie")))
135    (if cookie-hdr
136        (remove null?
137                (map (lambda (x)
138                       ;; Each cookie is a 'name=value' pair.  Otherwise ignore it.
139                       (match
140                        (string-match "[ \t]*([^ \t]+)[ \t]*=[ \t]*\"([^ \t]*)\"[ \t]*" x)
141                        ((_ name value) (cons name value))
142                        (_ '())))
143                                        ; RFC says we should accept `,' and `;' as cookie separators
144                     (string-split cookie-hdr ",;")))
145        (list))))
146
147;; From HTTP egg. TODO: export it
148(define (parse-encoded-arguments args)
149  (let ([vals (string-split args "&")])
150    (map (lambda (def)
151           (regex-case def
152             ["([^=]+)=(.*)" (_ name val)
153              (cons (http:canonicalize-string name) (http:canonicalize-string val))]
154             [else (cons (http:canonicalize-string def) "")] ) )
155         vals) ) )
Note: See TracBrowser for help on using the repository browser.