Changeset 15092 in project
- Timestamp:
- 06/28/09 20:23:10 (10 years ago)
- Location:
- release/4/http-client/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/http-client/trunk/http-client.meta
r15026 r15092 1 1 ((egg "http-client.egg") 2 2 (synopsis "High-level HTTP client library") 3 ( needs intarweb openssl)3 (depends intarweb openssl (uri-common 0.7)) 4 4 (author "Peter Bex") 5 5 (category net) -
release/4/http-client/trunk/http-client.scm
r15027 r15092 40 40 (use srfi-18 srfi-69 ports extras tcp openssl intarweb uri-common) 41 41 42 (define-record http-connection base-uri cookiesinport outport)42 (define-record http-connection base-uri inport outport) 43 43 44 44 (define max-retry-attempts (make-parameter 1)) … … 49 49 (define client-software 50 50 (make-parameter (list (list "Chicken Scheme HTTP-client" "0.1" #f)))) 51 52 ;; TODO: find a smarter storage mechanism 53 (define cookie-jar (list)) 51 54 52 55 (define connections … … 107 110 (close-output-port (http-connection-outport con))))) 108 111 109 (define (ensure-connection! uri #!optional (cookies '()))112 (define (ensure-connection! uri) 110 113 (or (get-connection uri) 111 114 (receive (in out) … … 114 117 ((https) (ssl-connect (uri-host uri) (uri-port uri))) 115 118 (else (error "Unknown URI scheme" (uri-scheme uri)))) 116 (let ((con (make-http-connection uri cookiesin out)))119 (let ((con (make-http-connection uri in out))) 117 120 (add-connection! uri con) 118 121 con)))) … … 140 143 (read-string len (response-port response)))) 141 144 145 ;; XXX TODO: Add a header unparser to intarweb for "cookie" headers 146 ;; Make cookie names also symbols. 142 147 (define (add-headers req) 143 148 (let* ((uri (request-uri req)) 144 ;; TODO: Add cookies145 (h `((host ,(cons (uri-host uri) (uri-port uri)))149 (h `((cookie . ,(get-cookies-for-uri (request-uri req))) 150 (host ,(cons (uri-host uri) (uri-port uri))) 146 151 (user-agent ,(client-software))))) 147 152 (update-request req headers: (headers h (request-headers req))))) … … 151 156 (make-property-condition 'exn 'location loc 'message msg) 152 157 (apply make-property-condition specific rest)))) 158 159 ;; RFC 2965, section 3.3.3 160 (define (cookie-eq? a b) 161 (let ((ref (lambda (cookie attr) (get-param attr cookie "")))) 162 (and (eq? (car (get-value a)) (car (get-value b))) 163 (string-ci=? (ref a 'domain) (ref b 'domain)) 164 (string=? (ref a 'path) (ref b 'path))))) 165 166 (define (store-cookie! cookie) 167 (let loop ((jar cookie-jar)) 168 (cond 169 ((null? jar) (set! cookie-jar (cons cookie cookie-jar)) cookie-jar) 170 ((cookie-eq? cookie (car jar)) 171 (set-car! jar cookie) 172 cookie-jar) 173 (else (loop (cdr jar)))))) 174 175 (define (domain-match? uri pattern) 176 (let ((target (uri-host uri))) 177 (or (string-ci=? target pattern) 178 (and (string-prefix? "." pattern) 179 (string-suffix-ci? pattern target))))) 180 181 ;; Things might be simpler if we used path list representation... 182 (define (path-match? uri path) 183 (and (uri-path-absolute? uri) 184 (let loop ((path (cdr (string-split path "/" #t))) 185 (uri-path (cdr (uri-path uri)))) 186 (or (null? path) ; done 187 (and (not (null? uri-path)) 188 (or (and (string-null? (car path)) (null? (cdr path))) 189 190 (and (string=? (car path) (car uri-path)) 191 (loop (cdr path) (cdr uri-path))))))))) 192 193 (define (get-cookies-for-uri uri) 194 (sort! 195 (filter (lambda (c) 196 (and (domain-match? uri (get-param 'domain c)) 197 (member (uri-port uri) 198 (get-param 'port c (list (uri-port uri)))) 199 (path-match? uri (get-param 'path c)) 200 (if (get-param 'secure c) 201 (member (uri-scheme uri) '(https shttp)) 202 #t))) 203 cookie-jar) 204 (lambda (a b) 205 (< (string-length (get-param 'path a)) 206 (string-length (get-param 'path b)))))) 207 208 (define (process-set-cookie! con uri r) 209 (let ((prefix-contains-dots? 210 (lambda (host pattern) 211 (string-index host #\. 0 (string-contains-ci host pattern))))) 212 (for-each (lambda (c) 213 (and-let* (((path-match? uri (get-param 'path c))) 214 ;; really, path should be in separated form! 215 (path (get-param 'path c (string-join (cdr (uri-path uri)) "/"))) 216 ;; domain must start with dot. Add to intarweb! 217 (dn (get-param 'domain c (uri-host uri))) 218 (idx (string-index dn #\.)) 219 ((domain-match? uri dn)) 220 ((not (prefix-contains-dots? (uri-host uri) dn)))) 221 ;; normalize the cookie as much as we have to 222 (store-cookie! (vector 223 (get-value c) 224 (alist-update! 'path path 225 (alist-update! 'domain dn (get-params c))))))) 226 (header-contents 'set-cookie (response-headers r) '())) 227 (for-each (lambda (c) 228 (and-let* (((get-param 'version c)) ; required for set-cookie2 229 (path (get-param 'path c (string-join (cdr (uri-path uri)) "/"))) 230 ((path-match? uri (get-param 'path c))) 231 (dn (get-param 'domain c (uri-host uri))) 232 ((or (string-ci=? dn ".local") 233 (and (not (string-null? dn)) 234 (string-index dn #\. 1)))) 235 ((domain-match? uri dn)) 236 ((not (prefix-contains-dots? (uri-host uri) dn))) 237 ;; This is a little bit too messy for my tastes... 238 ;; Can't use #f because that would shortcut and-let* 239 (ports-value (get-param 'port c 'any)) 240 (ports (if (eq? ports-value #t) 241 (list (uri-port uri)) 242 ports-value)) 243 ((or (eq? ports 'any) 244 (member (uri-port uri) ports)))) 245 ;; normalize the cookie as much as we have to 246 (store-cookie! 247 (vector 248 (get-value c) 249 (alist-update! 'path path 250 (alist-update! 'port (if (eq? ports 'any) 251 #f 252 ports) 253 (alist-update! 'domain dn (get-params c)))))))) 254 (header-contents 'set-cookie2 (response-headers r) '())))) 153 255 154 256 (define (call-with-response uri-or-request proc1 #!optional proc2) … … 178 280 (keep-alive? response)) 179 281 (close-connection! con))))) 282 (process-set-cookie! con uri response) 180 283 (cond 181 284 ;; TODO: According to spec, we should provide the user with a choice
Note: See TracChangeset
for help on using the changeset viewer.