Changeset 15204 in project


Ignore:
Timestamp:
07/09/09 21:28:04 (10 years ago)
Author:
sjamaan
Message:

Implement basic auth in a really ugly way. Digest auth to come

File:
1 edited

Legend:

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

    r15141 r15204  
    5050
    5151(define retry-request? (make-parameter idempotent?))
     52
     53;; Maybe only pass uri and realm to this?
     54(define determine-username/password
     55  (make-parameter (lambda (uri realm)
     56                    (values (uri-username uri) (uri-password uri)))))
    5257
    5358(define client-software
     
    267272  (let loop ((attempts 0)
    268273             (redirects 0)
    269              (uri (request-uri req)))
     274             (req req))
    270275    (condition-case
    271      (let* ((con (ensure-connection! uri))
     276     (let* ((con (ensure-connection! (request-uri req)))
    272277            (req (add-headers (update-request
    273                                req port: (http-connection-outport con)
    274                                uri: uri)))
     278                               req port: (http-connection-outport con))))
    275279            (request (write-request
    276280                      (update-request
     
    278282                       ;; only do this if not using a proxy
    279283                       uri: (update-uri (uri-reference "")
    280                                         path: (uri-path uri)
    281                                         query: (uri-query uri)))))
     284                                        path: (uri-path (request-uri req))
     285                                        query: (uri-query (request-uri req))))))
    282286            ;; Writer should be prepared to be called several times
    283287            ;; Maybe try and figure out a good way to use the
     
    290294                                     (keep-alive? response))
    291295                          (close-connection! con)))))
    292        (process-set-cookie! con uri response)
    293        (cond
     296       (process-set-cookie! con (request-uri req) response)
     297       (case (response-code response)
    294298        ;; TODO: According to spec, we should provide the user with a choice
    295299        ;; when it's not a GET or HEAD request...
    296         ((member (response-code response) '(301 302 303 307))
     300        ((301 302 303 307)
    297301         ;; Clear out data, throwing it away
    298302         (read-response-data response)
     
    308312               (loop attempts
    309313                     (add1 redirects)
    310                      (uri-relative-to new-uri uri))
     314                     (update-request req uri: (uri-relative-to
     315                                               new-uri (request-uri req))))
    311316               (http-client-error 'send-request
    312317                                  "Maximum number of redirects exceeded"
    313318                                  'redirect-depth-exceeded
    314319                                  'uri new-uri))))
     320        ((401)
     321         ;; Clear out data, throwing it away
     322         (read-response-data response)
     323         (cleanup!)
     324         (let ((authtype (header-value 'www-authenticate
     325                                        (response-headers response))))
     326           (if (and (or (not (max-retry-attempts)) ; unlimited?
     327                        (<= attempts (max-retry-attempts)))
     328                    ((retry-request?) req)
     329                    (and (member authtype '(basic digest))))
     330               (receive (username password)
     331                 ((determine-username/password)
     332                  (request-uri req)
     333                  (header-param 'www-authenticate 'realm
     334                                (response-headers response)))
     335                 (case authtype
     336                   ((basic)
     337                    (loop (add1 attempts)
     338                          redirects
     339                          (update-request
     340                           req
     341                           headers: (headers
     342                                     `((authorization
     343                                        #(basic ((username . ,username)
     344                                                 (password . ,password)))))
     345                                     (request-headers req)))))
     346                   ((digest)
     347                    (loop (add1 attempts) redirects req)) ;; TODO
     348                   (else (error "Should never get here"))))
     349               ;; pass it on, we can't throw an error here
     350               (let ((data (reader response)))
     351                 (cleanup!)
     352                 (values data (request-uri req) response)))))
    315353        (else (let ((data (reader response)))
    316                 (cleanup!)
    317                 (values data uri response)))))
     354           (cleanup!)
     355           (values data (request-uri req) response)))))
    318356     (exn (exn i/o net)
    319           (close-connection! uri)
     357          (close-connection! (request-uri req))
    320358          (if (and (or (not (max-retry-attempts)) ; unlimited?
    321359                       (<= attempts (max-retry-attempts)))
    322360                   ((retry-request?) req))
    323               (loop (add1 attempts) redirects uri)
     361              (loop (add1 attempts) redirects req)
    324362              (signal exn)))
    325363     (exn ()
     
    327365          ;; (the error could have occurred while reading, so there
    328366          ;;  might be data left in the buffer)
    329           (close-connection! uri)
     367          (close-connection! (request-uri req))
    330368          (raise exn)))))
    331369
Note: See TracChangeset for help on using the changeset viewer.