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

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

Make cookies interface more consistent with the rest of web-unity

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:query-params (make-parameter #f))
34(define wu:path-info (make-parameter #f))
35(define wu:script-name (make-parameter #f))
36(define wu:script-filename (make-parameter #f))
37(define wu:request-method (make-parameter #f))
38(define wu:response-headers (make-parameter #f))
39(define wu:response-code (make-parameter '(200 . "OK")))
40(define wu:headers-sent (make-parameter #f))
41
42;; Basically copied from Spiffy
43(define generate-error-message
44  (let ()
45    (define exn-message (condition-property-accessor 'exn 'message "(no message)"))
46    (define exn-location (condition-property-accessor 'exn 'location "(unknown location)"))
47    (define exn-arguments (condition-property-accessor 'exn 'arguments '()))
48    (define exn? (condition-predicate 'exn))
49    (lambda (exn)
50      (let ((chain (with-output-to-string print-call-chain)))
51        (with-output-to-string
52          (lambda ()
53            (if (exn? exn)
54                (begin
55                  (display "<h2>Error:")
56                  (and-let* ([loc (exn-location exn)])
57                            (printf " (<em>~A</em>)" (htmlize (->string loc))))
58                  (printf "</h2><h3>~A</h3>" (htmlize (exn-message exn)))
59                  (unless (null? (exn-arguments exn))
60                          (printf "<ul>")
61                          (for-each
62                           (lambda (a)
63                             (##sys#with-print-length-limit 120 (lambda () (printf "<li>~S</li>" (htmlize (->string a))))))
64                           (exn-arguments exn))
65                          (printf "</ul>"))
66                  (printf "<pre>~a</pre>" (htmlize chain)))
67                (begin
68                  (##sys#with-print-length-limit
69                   120
70                   (lambda ()
71                     (printf "<hr /><strong>Uncaught exception:</strong> ~S" exn)))))))))))
72
73(define wu:exception-handler
74  (make-parameter (lambda (exn)
75                    (printf
76                     "<!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>"
77                     (generate-error-message exn)))))
78
79(define (wu:invoke-dispatcher dispatcher)
80  (parameterize ((wu:headers-sent #f)
81                 (wu:cookies (get-request-cookies)))
82   (handle-exceptions exn (begin (unless (wu:headers-sent)
83                                         (parameterize ((wu:response-code '(500 . "Internal server error")))
84                                           (wu:write-headers)))
85                                 ((wu:exception-handler) exn))
86                      (dispatcher))))
87
88(load-verbose #f)  ;; No "loading xyz.scm..." in output
89
90; Add http/1.1 chunking to an existing output port
91(define (wu:chunked-output-port p)
92  (make-output-port
93   (lambda (data)
94     (fprintf p "~X\r\n~A\r\n" (string-length data) data))
95   void))
96
97;; From Spiffy
98(define (wu:single-header? name)
99  (not (member name '("Set-Cookie") string-ci=?)))
100
101(define (wu:set-header! name value)
102  (if (wu:single-header? name)
103      (let* ([rh (wu:response-headers)]
104             [a (assoc name rh string-ci=?)] )
105        (if a
106            (set-cdr! a value)
107            (wu:response-headers (alist-cons name value rh)) ) )
108      (wu:response-headers (alist-cons name value (wu:response-headers)))))
109
110;;; Cookie procedures taken from spiffy-utils and ported to WU
111(define (wu:cookie-set! name value . args)
112  (let ((conc-cond (lambda (s1 s2 s3) (if s2 (conc s1 s2 s3) ""))))
113    (let-optionals args ((comment #f) (max-age #f) (domain #f) (path #f)
114                         (secure #f))
115                   (wu:set-header! "Set-Cookie"
116                    (string-append (->string name) "=\"" (->string value) "\""
117                                   (conc-cond "; Comment=\"" comment "\"")
118                                   (conc-cond "; Max-Age=\"" max-age "\"")
119                                   (conc-cond "; Domain=\"" domain "\"")
120                                   (conc-cond "; Path=\"" path "\"")
121                                   (if secure "; Secure" "")
122                                   "; Version=1")))))
123
124;;; Delete a cookie by settings its maximum age to 0 seconds
125(define (wu:cookie-delete! name . args)
126  (let-optionals args ((domain #f) (path #f))
127    (wu:cookie-set! (->string name) "" #f 0 domain path)))
128
129; Get "cookie variable" value
130; TODO: Implement cookie handling better we can get a cookie's Path/Domain
131;        and make the `$Version' cookie disappear to the user.
132(define (get-request-cookies)
133  (let ((cookie-hdr (wu:get-header "cookie")))
134    (if cookie-hdr
135        (remove null?
136                (map (lambda (x)
137                       ;; Each cookie is a 'name=value' pair.  Otherwise ignore it.
138                       (match
139                        (string-match "[ \t]*([^ \t]+)[ \t]*=[ \t]*\"([^ \t]*)\"[ \t]*" x)
140                        ((_ name value) (cons name value))
141                        (_ '())))
142                                        ; RFC says we should accept `,' and `;' as cookie separators
143                     (string-split cookie-hdr ",;")))
144        (list))))
145
146;; From HTTP egg. TODO: export it
147(define (parse-encoded-arguments args)
148  (let ([vals (string-split args "&")])
149    (map (lambda (def)
150           (regex-case def
151             ["([^=]+)=(.*)" (_ name val)
152              (cons (http:canonicalize-string name) (http:canonicalize-string val))]
153             [else (cons (http:canonicalize-string def) "")] ) )
154         vals) ) )
Note: See TracBrowser for help on using the repository browser.