source: project/release/3/http/tags/2.5.2/http-utils.scm @ 10765

Last change on this file since 10765 was 9415, checked in by Jim Ursetto, 12 years ago

http-utils: Reduce GC significantly for http:canonicalize-string

File size: 6.8 KB
Line 
1;;;; http-utils.scm - Utility routines - felix
2;
3; Copyright (c) 2000-2005, Felix L. Winkelmann
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; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(declare
37  (fixnum)
38  (export 
39   http:decode-url http:canonicalize-string
40   http:read-line-limit http:request-limit
41   http:read-request-attributes
42   http:make-request http:request? http:request-url http:request-protocol http:request-attributes http:request-body http:request-method
43   http:request-url-set! http:request-protocol-set! http:request-attributes-set! http:request-body-set! http:request-method-set!
44   http:request-ip http:request-ip-set! http:request-completion http:request-completion-set!
45   http:request-sslctx http:request-sslctx-set! http:request-unparsed-body http:request-unparsed-body-set!
46   http:request-attribute-get http:request-attribute-add!
47   http:request-attribute-del!
48   ) )
49
50(declare (uses srfi-1 srfi-13 srfi-18 regex))
51
52(require-extension regex-case)
53
54
55;;; Constants:
56
57(define-constant default-read-line-limit 1024)
58(define-constant default-request-limit 1000000)
59
60
61;;; I/O utilities:
62
63(define http:read-line-limit (make-parameter default-read-line-limit))
64(define http:request-limit (make-parameter default-request-limit))
65
66
67;;; Requests:
68
69(define-record http:request
70  method                                ; symbol
71  attributes                            ; ((string1 . string2) ...)
72  ip                                    ; string
73  url                                   ; string
74  protocol                              ; symbol
75  body                                  ; string | #f (possibly identical to unparsed body)
76  unparsed-body                         ; string
77  completion                            ; procedure | #f
78  sslctx)                               ; <ssl-client-context|symbol> | 'sslv2-or-v3
79
80(define http:make-request
81  (let ([make-http:request make-http:request])
82    (lambda (method url . more)
83      (let-optionals more ([attrs '()] [body '()] [unpbody ""] [protocol 'HTTP/1.0] [ip "<unknown>"])
84        (make-http:request method attrs ip url protocol body unpbody #f 'sslv2-or-v3) ) ) ) )
85
86(define http:read-request-attributes 
87  (let ((rx (if (feature? 'pregexp) 
88                "([\\-A-Za-z0-9]+):[ ]*([^ ].*)"
89                "([-A-Za-z0-9]+):[ ]*([^ ].*)") ) )
90    (lambda (port)
91      (let ([limit (http:read-line-limit)]
92            (total (http:request-limit)))
93        (let loop ([attrs '()] [prev #f] [cnt 0])
94          (let  ([ln (read-line port limit)])
95            (cond [(or (eof-object? ln) (string-null? ln)) attrs] ; signal error?
96                  [(fx> cnt total) #f]
97                  [(char-whitespace? (string-ref ln 0))
98                   (set-cdr! prev (string-append (cdr prev) " " ln)) 
99                   (loop attrs prev (fx+ cnt (string-length ln)))]
100                  [else
101                   (regex-case ln
102                     [rx (_ a val)
103                         (let ([a (cons (string-downcase a) val)])
104                           (loop (cons a attrs) a (fx+ cnt (string-length ln))) ) ]
105                     [else #f] ) ] ) ) ) ) ) ) )
106
107(define (http:request-attribute-get req attr #!optional (default #f))
108    (or (http:request? req)
109        (error 'http:request-attribute-get "not a http:request object" req))
110    (or (and (string? attr) (not (string-null? attr)))
111        (error 'http:request-attribute-get "not a valid string" attr))
112    (let ((r   (alist-ref attr (http:request-attributes req) string-ci=?)))
113        (if r
114            r
115            default)))
116
117(define (http:request-attribute-add! req attr val)
118    (or (http:request? req)
119        (error 'http:request-attribute-add! "not a http:request object" req))
120    (or (and (string? attr) (not (string-null? attr)))
121        (error 'http:request-attribute-add! "not a valid string" attr))
122    (let ((r   (assoc attr (http:request-attributes req) string-ci=?)))
123        (if r
124            (set-cdr! r (->string val))
125            (http:request-attributes-set! req
126                (append (http:request-attributes req)
127                        (list (cons attr (->string val))))))
128        req))
129
130(define (http:request-attribute-del! req attr)
131    (or (http:request? req)
132        (error 'http:request-attribute-del! "not a http:request object" req))
133    (or (and (string? attr) (not (string-null? attr)))
134        (error 'http:request-attribute-del! "not a valid string" attr))
135    (http:request-attributes-set! req
136        (fold-right
137            (lambda (e r)
138                (if (string-ci=? attr (car e))
139                    r
140                    (cons e r)))
141            '()
142            (http:request-attributes req)))
143    req)
144
145
146;;; URL and string operations:
147
148(define (http:decode-url url)
149  (regex-case url
150    ["([^?]+)\\?(.*)" (_ loc args)
151     (values
152      (http:unescape-string loc)
153      (parse-encoded-arguments args) ) ] 
154    [else (values (http:unescape-string url) '())] ) )
155
156(define (http:canonicalize-string str)
157  (http:unescape-string
158   (string-translate str "+" " ")))
159
160(define (http:unescape-string str)
161  (let ((re (regexp "%[0-9ABCDEFabcdef]{2}")))
162    (let loop ([i 0] (accum '()))
163      (match (string-search-positions re str i)
164        [((i1 i2))
165         (loop
166          i2
167          (cons
168           (string (integer->char (string->number (substring str (fx+ i1 1) i2) 16)))
169           (cons (substring str i i1) accum)))]
170        [#f (if (null? accum)
171                str
172                (string-concatenate-reverse (cons (substring str i) accum)))] ))))
173
174(define (parse-encoded-arguments args)
175  (let ([vals (string-split args "&")])
176    (map (lambda (def)
177           (regex-case def
178             ["([^=]+)=(.*)" (_ name val)
179              (cons (http:canonicalize-string name) (http:canonicalize-string val))]
180             [else (cons (http:canonicalize-string def) "")] ) )
181         vals) ) )
Note: See TracBrowser for help on using the repository browser.