Changeset 15092 in project


Ignore:
Timestamp:
06/28/09 20:23:10 (10 years ago)
Author:
sjamaan
Message:

Implement basic cookie management

Location:
release/4/http-client/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/http-client/trunk/http-client.meta

    r15026 r15092  
    11((egg "http-client.egg")
    22 (synopsis "High-level HTTP client library")
    3  (needs intarweb openssl)
     3 (depends intarweb openssl (uri-common 0.7))
    44 (author "Peter Bex")
    55 (category net)
  • release/4/http-client/trunk/http-client.scm

    r15027 r15092  
    4040(use srfi-18 srfi-69 ports extras tcp openssl intarweb uri-common)
    4141
    42 (define-record http-connection base-uri cookies inport outport)
     42(define-record http-connection base-uri inport outport)
    4343
    4444(define max-retry-attempts (make-parameter 1))
     
    4949(define client-software
    5050  (make-parameter (list (list "Chicken Scheme HTTP-client" "0.1" #f))))
     51
     52;; TODO: find a smarter storage mechanism
     53(define cookie-jar (list))
    5154
    5255(define connections
     
    107110     (close-output-port (http-connection-outport con)))))
    108111
    109 (define (ensure-connection! uri #!optional (cookies '()))
     112(define (ensure-connection! uri)
    110113  (or (get-connection uri)
    111114      (receive (in out)
     
    114117          ((https) (ssl-connect (uri-host uri) (uri-port uri)))
    115118          (else (error "Unknown URI scheme" (uri-scheme uri))))
    116         (let ((con (make-http-connection uri cookies in out)))
     119        (let ((con (make-http-connection uri in out)))
    117120          (add-connection! uri con)
    118121          con))))
     
    140143    (read-string len (response-port response))))
    141144
     145;; XXX TODO: Add a header unparser to intarweb for "cookie" headers
     146;; Make cookie names also symbols.
    142147(define (add-headers req)
    143148  (let* ((uri (request-uri req))
    144          ;; TODO: Add cookies
    145          (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)))
    146151              (user-agent ,(client-software)))))
    147152    (update-request req headers: (headers h (request-headers req)))))
     
    151156          (make-property-condition 'exn 'location loc 'message msg)
    152157          (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) '()))))
    153255
    154256(define (call-with-response uri-or-request proc1 #!optional proc2)
     
    178280                                       (keep-alive? response))
    179281                            (close-connection! con)))))
     282         (process-set-cookie! con uri response)
    180283         (cond
    181284          ;; TODO: According to spec, we should provide the user with a choice
Note: See TracChangeset for help on using the changeset viewer.