Changeset 15159 in project


Ignore:
Timestamp:
07/05/09 14:41:40 (10 years ago)
Author:
sjamaan
Message:

Add initial digest auth unparser

Location:
release/4/intarweb/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/intarweb/trunk/header-parsers.scm

    r15158 r15159  
    500500
    501501;;; Unparsers ;;;
    502 (define (unparse-params params unparsers)
     502(define (unparse-params params unparsers #!optional (separator "; ") (grammar 'prefix))
    503503  (let loop ((params params)
    504504             (results '()))
    505505    (if (null? params)
    506         (string-join (reverse results) "; " 'prefix)
    507         (let* ((unparser (alist-ref unparsers (caar params) eq?
    508                                     (lambda (attribute value)
    509                                       (case value
    510                                         ;; #t means param is present (no value)
    511                                         ((#t) (symbol->http-name attribute))
    512                                         ;; #f means param is missing
    513                                         ((#f) #f)
    514                                         (else
    515                                          (sprintf "~A=~A"
    516                                                   (symbol->http-name attribute)
    517                                                   value))))))
    518                (str (unparser (caar params) (cdar params))))
     506        (string-join (reverse results) separator grammar)
     507        (let* ((name (caar params))
     508               (val (cdar params))
     509               (str (case val
     510                      ;; #t means param is present (no value)
     511                      ((#t) (symbol->http-name name))
     512                      ;; #f means param is missing
     513                      ((#f) #f)
     514                      (else (let ((unparser (alist-ref name unparsers
     515                                                       eq? identity)))
     516                              (sprintf "~A=~A"
     517                                       (unparse-token (symbol->http-name name))
     518                                       (unparse-token (unparser val))))))))
    519519          (loop (cdr params) (if str (cons str results) results))))))
    520520
     
    641641             (result '()))
    642642    (if (null? headers)
    643         (string-join result ", ")
     643        (string-join result ", ")  ; XXX will this work?
    644644        (let ((contents               
    645645               (case (get-value (car headers))
     
    653653                                (base64-encode
    654654                                 (sprintf "~A:~A" user pass))))))
     655                 ((digest)
     656                  (sprintf "~A ~A"
     657                           (symbol->http-name (get-value (car headers)))
     658                           (unparse-params (get-params (car headers))
     659                                           `((nc . ,(lambda (n)
     660                                                      (string-pad
     661                                                       (number->string n 16)
     662                                                       8 #\0)))
     663                                             (uri . ,uri->string)
     664                                             (qop . ,symbol->string))
     665                                           ", "
     666                                           'infix)))
    655667                 (else
    656668                  (sprintf "~A ~A"
  • release/4/intarweb/trunk/tests/run.scm

    r15158 r15159  
    524524    (test "Basic auth"
    525525          "Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==\r\n"
    526           (test-unparse-headers `((authorization #(basic
    527                                                    ((username . "Aladdin")
    528                                                     (password . "open sesame")))))))
     526          (test-unparse-headers
     527           `((authorization #(basic
     528                              ((username . "Aladdin")
     529                               (password . "open sesame")))))))
    529530    (test-error* "Basic auth with colon in username"
    530531                 (http username-with-colon)
     
    532533                  `((authorization #(basic
    533534                                     ((username . "foo:bar")
    534                                       (password . "qux")))))))))
     535                                      (password . "qux")))))))
     536    (test "Digest auth"
     537          "Authorization: Digest Username=Mufasa, Realm=testrealm@host.com, Nonce=dcd98b7102dd2f0e8b11d0f600bfb0c093, Uri=/dir/index.html, Qop=auth, Cnonce=0a4f113b, Response=6629fae49393a05397450978507c4ef1, Opaque=5ccc069c403ebaf9f0171e9517f40e41, Nc=00000001\r\n"
     538          (test-unparse-headers
     539           `((authorization #(digest
     540                              ((username . "Mufasa")
     541                               (realm . "testrealm@host.com")
     542                               (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
     543                               (uri . ,(uri-reference "/dir/index.html"))
     544                               (qop . auth)
     545                               (cnonce . "0a4f113b")
     546                               (response . "6629fae49393a05397450978507c4ef1")
     547                               (opaque . "5ccc069c403ebaf9f0171e9517f40e41")
     548                               (nc . 1)))))))))
    535549
    536550(define (test-read-request str)
Note: See TracChangeset for help on using the changeset viewer.