Changeset 15092 in project

Timestamp:

06/28/09 20:23:10 (10 years ago)

Author:

sjamaan

Message:

Implement basic cookie management

Location:

release/4/http-client/trunk

Files:

• http-client.meta (modified) (1 diff)
• http-client.scm (modified) (7 diffs)

release/4/http-client/trunk/http-client.meta

@@ -1 +1 @@
 ((egg "http-client.egg")
  (synopsis "High-level HTTP client library")
- (needs intarweb openssl)
+ (depends intarweb openssl (uri-common 0.7))
  (author "Peter Bex")
  (category net)

release/4/http-client/trunk/http-client.scm

@@ -40 +40 @@
 (use srfi-18 srfi-69 ports extras tcp openssl intarweb uri-common)
 
-(define-record http-connection base-uri cookies inport outport)
+(define-record http-connection base-uri inport outport)
 
 (define max-retry-attempts (make-parameter 1))
@@ -49 +49 @@
 (define client-software
   (make-parameter (list (list "Chicken Scheme HTTP-client" "0.1" #f))))
+
+;; TODO: find a smarter storage mechanism
+(define cookie-jar (list))
 
 (define connections
@@ -107 +110 @@
      (close-output-port (http-connection-outport con)))))
 
-(define (ensure-connection! uri #!optional (cookies '()))
+(define (ensure-connection! uri)
   (or (get-connection uri)
       (receive (in out)
@@ -114 +117 @@
           ((https) (ssl-connect (uri-host uri) (uri-port uri)))
           (else (error "Unknown URI scheme" (uri-scheme uri))))
-        (let ((con (make-http-connection uri cookies in out)))
+        (let ((con (make-http-connection uri in out)))
           (add-connection! uri con)
           con))))
@@ -140 +143 @@
     (read-string len (response-port response))))
 
+;; XXX TODO: Add a header unparser to intarweb for "cookie" headers
+;; Make cookie names also symbols.
 (define (add-headers req)
   (let* ((uri (request-uri req))
-         ;; TODO: Add cookies
-         (h `((host ,(cons (uri-host uri) (uri-port uri)))
+         (h `((cookie . ,(get-cookies-for-uri (request-uri req)))
+              (host ,(cons (uri-host uri) (uri-port uri)))
               (user-agent ,(client-software)))))
     (update-request req headers: (headers h (request-headers req)))))
@@ -151 +156 @@
           (make-property-condition 'exn 'location loc 'message msg)
           (apply make-property-condition specific rest))))
+
+;; RFC 2965, section 3.3.3
+(define (cookie-eq? a b)
+  (let ((ref (lambda (cookie attr) (get-param attr cookie ""))))
+    (and (eq?         (car (get-value a)) (car (get-value b)))
+         (string-ci=? (ref a 'domain)     (ref b 'domain))
+         (string=?    (ref a 'path)       (ref b 'path)))))
+
+(define (store-cookie! cookie)
+  (let loop ((jar cookie-jar))
+    (cond
+     ((null? jar) (set! cookie-jar (cons cookie cookie-jar)) cookie-jar)
+     ((cookie-eq? cookie (car jar))
+      (set-car! jar cookie)
+      cookie-jar)
+     (else (loop (cdr jar))))))
+
+(define (domain-match? uri pattern)
+  (let ((target (uri-host uri)))
+    (or (string-ci=? target pattern)
+        (and (string-prefix? "." pattern)
+             (string-suffix-ci? pattern target)))))
+
+;; Things might be simpler if we used path list representation...
+(define (path-match? uri path)
+  (and (uri-path-absolute? uri)
+       (let loop ((path (cdr (string-split path "/" #t)))
+                  (uri-path (cdr (uri-path uri))))
+         (or (null? path)               ; done
+             (and (not (null? uri-path))
+                  (or (and (string-null? (car path)) (null? (cdr path)))
+
+                      (and (string=? (car path) (car uri-path))
+                           (loop (cdr path) (cdr uri-path)))))))))
+
+(define (get-cookies-for-uri uri)
+  (sort!
+   (filter (lambda (c)
+             (and (domain-match? uri (get-param 'domain c))
+                  (member (uri-port uri)
+                          (get-param 'port c (list (uri-port uri))))
+                  (path-match? uri (get-param 'path c))
+                  (if (get-param 'secure c)
+                      (member (uri-scheme uri) '(https shttp))
+                      #t)))
+           cookie-jar)
+   (lambda (a b)
+     (< (string-length (get-param 'path a))
+        (string-length (get-param 'path b))))))
+
+(define (process-set-cookie! con uri r)
+  (let ((prefix-contains-dots?
+         (lambda (host pattern)
+           (string-index host #\. 0 (string-contains-ci host pattern)))))
+    (for-each (lambda (c)
+                (and-let* (((path-match? uri (get-param 'path c)))
+                           ;; really, path should be in separated form!
+                           (path (get-param 'path c (string-join (cdr (uri-path uri)) "/")))
+                           ;; domain must start with dot. Add to intarweb!
+                           (dn (get-param 'domain c (uri-host uri)))
+                           (idx (string-index dn #\.))
+                           ((domain-match? uri dn))
+                           ((not (prefix-contains-dots? (uri-host uri) dn))))
+                  ;; normalize the cookie as much as we have to
+                  (store-cookie! (vector
+                                  (get-value c)
+                                  (alist-update! 'path path
+                                                 (alist-update! 'domain dn (get-params c)))))))
+              (header-contents 'set-cookie (response-headers r) '()))
+    (for-each (lambda (c)
+                (and-let* (((get-param 'version c)) ; required for set-cookie2
+                           (path (get-param 'path c (string-join (cdr (uri-path uri)) "/")))
+                           ((path-match? uri (get-param 'path c)))
+                           (dn (get-param 'domain c (uri-host uri)))
+                           ((or (string-ci=? dn ".local")
+                                (and (not (string-null? dn))
+                                     (string-index dn #\. 1))))
+                           ((domain-match? uri dn))
+                           ((not (prefix-contains-dots? (uri-host uri) dn)))
+                           ;; This is a little bit too messy for my tastes...
+                           ;; Can't use #f because that would shortcut and-let*
+                           (ports-value (get-param 'port c 'any))
+                           (ports (if (eq? ports-value #t)
+                                      (list (uri-port uri))
+                                      ports-value))
+                           ((or (eq? ports 'any)
+                                (member (uri-port uri) ports))))
+                  ;; normalize the cookie as much as we have to
+                  (store-cookie!
+                   (vector
+                    (get-value c)
+                    (alist-update! 'path path
+                                   (alist-update! 'port (if (eq? ports 'any)
+                                                            #f
+                                                            ports)
+                                                  (alist-update! 'domain dn (get-params c))))))))
+              (header-contents 'set-cookie2 (response-headers r) '()))))
 
 (define (call-with-response uri-or-request proc1 #!optional proc2)
@@ -178 +280 @@
                                        (keep-alive? response))
                             (close-connection! con)))))
+         (process-set-cookie! con uri response)
          (cond
           ;; TODO: According to spec, we should provide the user with a choice