Changeset 15162 in project


Ignore:
Timestamp:
07/05/09 16:50:12 (12 years ago)
Author:
sjamaan
Message:

Add authenticate unparser

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

Legend:

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

    r15161 r15162  
    696696                           (unparse-params (get-params (car headers)) '()))))))
    697697         (loop (cdr headers) (cons contents result))))))
     698
     699(define (authenticate-unparser header-name header-contents)
     700  (let loop ((headers (reverse header-contents))
     701             (result '()))
     702    (if (null? headers)
     703        (string-join result ", ")  ; XXX will this work?
     704        (let ((contents
     705               (sprintf "~A ~A"
     706                        (symbol->http-name (get-value (car headers)))
     707                        (let* ((old (get-params (car headers)))
     708                               ;; A quick hack to get presence of "stale"
     709                               ;; coded as TRUE instead of value-less param
     710                               ;; false value is coded by its absense
     711                               (params (if (alist-ref 'stale old)
     712                                           (alist-update! 'stale 'TRUE old)
     713                                           (alist-delete 'stale old))))
     714                         (unparse-params params
     715                                         `((domain . ,(lambda (u)
     716                                                        (string-join
     717                                                         (map uri->string u))))
     718                                           (qop . ,(lambda (q)
     719                                                     (string-join
     720                                                      (map symbol->string q)
     721                                                      ",")))
     722                                           (algorithm . ,symbol->string))
     723                                         ", "
     724                                         'infix)))))
     725         (loop (cdr headers) (cons contents result))))))
  • release/4/intarweb/trunk/intarweb.scm

    r15161 r15162  
    451451     (cookie . ,cookie-unparser)
    452452     (authorization . ,authorization-unparser)
    453      (proxy-authorization . ,authorization-unparser))))
     453     (www-authenticate . ,authenticate-unparser)
     454     (proxy-authorization . ,authorization-unparser)
     455     (proxy-authenticate . ,authenticate-unparser))))
    454456
    455457(define (unparse-header header-name header-value)
  • release/4/intarweb/trunk/tests/run.scm

    r15161 r15162  
    200200              (header-param 'algorithm 'authorization headers)))))
    201201 
    202   (test-group "www-authenticate parser"
     202  (test-group "authenticate parser"
    203203    (test-group "basic auth"
    204204      (let ((headers (test-read-headers "WWW-Authenticate: Basic realm=\"WallyWorld\"")))
     
    592592                               (opaque . "5ccc069c403ebaf9f0171e9517f40e41")
    593593                               (nc . 1)
    594                                (algorithm . md5)))))))))
     594                               (algorithm . md5))))))))
     595
     596  (test-group "authenticate unparser"
     597    (test-group "basic auth"
     598      (test "basic"
     599            "Www-Authenticate: Basic Realm=WallyWorld\r\n"
     600            (test-unparse-headers
     601             `((www-authenticate #(basic
     602                                   ((realm . "WallyWorld"))))))))
     603    (test-group "digest auth"
     604      (test "digest"
     605            "Www-Authenticate: Digest Realm=testrealm@host.com, Qop=\"auth,auth-int\", Nonce=dcd98b7102dd2f0e8b11d0f600bfb0c093, Opaque=5ccc069c403ebaf9f0171e9517f40e41\r\n"
     606            (test-unparse-headers
     607             `((www-authenticate #(digest
     608                                   ((realm . "testrealm@host.com")
     609                                    (qop . (auth auth-int))
     610                                    (nonce . "dcd98b7102dd2f0e8b11d0f600bfb0c093")
     611                                    (opaque . "5ccc069c403ebaf9f0171e9517f40e41")))))))
     612      (test "domains"
     613            "Www-Authenticate: Digest Domain=\"/example http://foo.com/bar\"\r\n"
     614            (test-unparse-headers
     615             `((www-authenticate #(digest
     616                                   ((domain . (,(uri-reference "/example")
     617                                               ,(uri-reference "http://foo.com/bar")))))))))
     618      (test "stale"
     619            "Www-Authenticate: Digest Realm=foo, Stale=TRUE\r\n"
     620            (test-unparse-headers
     621             `((www-authenticate #(digest
     622                                   ((realm . "foo")
     623                                    (stale . #t)))))))
     624      (test "stale present but false"
     625            "Www-Authenticate: Digest Realm=foo\r\n"
     626            (test-unparse-headers
     627             `((www-authenticate #(digest
     628                                   ((realm . "foo")
     629                                    (stale . #f))))))))))
    595630
    596631(define (test-read-request str)
Note: See TracChangeset for help on using the changeset viewer.