Changeset 15161 in project


Ignore:
Timestamp:
07/05/09 16:07:59 (11 years ago)
Author:
sjamaan
Message:

Complete authenticate parser

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

Legend:

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

    r15160 r15161  
    424424  (let loop ((pos 0)
    425425             (result '()))
    426    (receive (authtype pos)
    427      (parse-token contents pos char-set:whitespace)
    428      (if (not authtype)
    429          (reverse result)
    430          (let ((authtype (http-name->symbol authtype)))
    431            (case authtype
    432              ((basic) (receive (secret pos)
    433                         (parse-token contents (add1 pos) (char-set #\,))
    434                         (let* ((decoded (base64-decode secret))
    435                                (colon-idx (string-index decoded #\:))
    436                                (user (string-take decoded colon-idx))
    437                                (pass (string-drop decoded (add1 colon-idx))))
     426    (receive (authtype pos)
     427      (parse-token contents pos char-set:whitespace)
     428      (if (not authtype)
     429          (reverse result)
     430          (let ((authtype (http-name->symbol authtype)))
     431            (case authtype
     432              ((basic) (receive (secret pos)
     433                         (parse-token contents (add1 pos) (char-set #\,))
     434                         (let* ((decoded (base64-decode secret))
     435                                (colon-idx (string-index decoded #\:))
     436                                (user (string-take decoded colon-idx))
     437                                (pass (string-drop decoded (add1 colon-idx))))
     438                           (loop (add1 pos)
     439                                 (cons (vector authtype
     440                                               `((username . ,user)
     441                                                 (password . ,pass))) result)))))
     442              ((digest) (receive (params pos)
     443                          (parse-parameters contents pos
     444                                            `((nc . ,(lambda (n)
     445                                                       (string->number n 16)))
     446                                              (uri . ,uri-reference)
     447                                              (qop . ,symbol-subparser)
     448                                              (algorithm . ,symbol-subparser-ci))
     449                                            (char-set #\,))
    438450                          (loop (add1 pos)
    439                                 (cons (vector authtype
    440                                               `((username . ,user)
    441                                                 (password . ,pass))) result)))))
    442              ((digest) (receive (params pos)
    443                          (parse-parameters contents pos
    444                                            `((nc . ,(lambda (n)
    445                                                       (string->number n 16)))
    446                                              (uri . ,uri-reference)
    447                                              (qop . ,symbol-subparser)
    448                                              (algorithm . ,symbol-subparser-ci))
    449                                            (char-set #\,))
    450                          (loop (add1 pos)
    451                                (cons (vector authtype params) result))))
    452              (else (receive (params pos)
    453                      (parse-parameters contents (add1 pos) '())
    454                      (loop (add1 pos)
    455                            (cons (vector authtype params) result))))))))))
     451                                (cons (vector authtype params) result))))
     452              (else (receive (params pos)
     453                      (parse-parameters contents (add1 pos) '())
     454                      (loop (add1 pos)
     455                            (cons (vector authtype params) result))))))))))
     456
     457(define (authenticate-parser contents)
     458  (let loop ((pos 0)
     459             (result '()))
     460    (receive (authtype pos)
     461      (parse-token contents pos char-set:whitespace)
     462      (if (not authtype)
     463          (reverse result)
     464          (let ((authtype (http-name->symbol authtype)))
     465            (receive (params pos)
     466              (parse-parameters contents pos
     467                                `((domain . ,(lambda (s)
     468                                               (map uri-reference
     469                                                    (string-split s))))
     470                                  (qop . ,(lambda (s)
     471                                            (map (compose symbol-subparser
     472                                                          string-trim)
     473                                                 (string-split s ","))))
     474                                  (algorithm . ,symbol-subparser-ci)
     475                                  (stale . ,(lambda (s)
     476                                              (string-ci=? (string-trim s)
     477                                                           "TRUE"))))
     478                                (char-set #\,))
     479              (loop (add1 pos) (cons (vector authtype params) result))))))))
    456480
    457481(define (pragma-parser contents)
  • release/4/intarweb/trunk/intarweb.scm

    r15155 r15161  
    314314     (max-forwards . ,(single natnum-subparser))
    315315     (pragma . ,pragma-parser)
    316      (proxy-authenticate . ,(multiple symbol-subparser-ci))
     316     (proxy-authenticate . ,authenticate-parser)
    317317     (proxy-authorization . ,authorization-parser)
    318318     (range . ,(multiple range-subparser))
     
    328328     (via . ,via-parser)
    329329     (warning . ,warning-parser)
    330      (www-authenticate . ,(single symbol-subparser-ci))
     330     (www-authenticate . ,authenticate-parser)
    331331     ;; RFC 2109
    332332     (set-cookie . ,set-cookie-parser)
  • release/4/intarweb/trunk/tests/run.scm

    r15160 r15161  
    199199              'md5
    200200              (header-param 'algorithm 'authorization headers)))))
     201 
     202  (test-group "www-authenticate parser"
     203    (test-group "basic auth"
     204      (let ((headers (test-read-headers "WWW-Authenticate: Basic realm=\"WallyWorld\"")))
     205        (test "basic"
     206              'basic
     207              (header-value 'www-authenticate headers))
     208        (test "realm"
     209              "WallyWorld"
     210              (header-param 'realm 'www-authenticate headers))))
     211    (test-group "digest auth"
     212      (let ((headers (test-read-headers "WWW-Authenticate: Digest realm=\"testrealm@host.com\", qop=\"auth, auth-int\", nonce=\"dcd98b7102dd2f0e8b11d0f600bfb0c093\", opaque=\"5ccc069c403ebaf9f0171e9517f40e41\"")))
     213        (test "digest"
     214              'digest
     215              (header-value 'www-authenticate headers))
     216        (test "realm"
     217              "testrealm@host.com"
     218              (header-param 'realm 'www-authenticate headers))
     219        (test "qop"
     220              '(auth auth-int)
     221              (header-param 'qop 'www-authenticate headers))
     222        (test "nonce"
     223              "dcd98b7102dd2f0e8b11d0f600bfb0c093"
     224              (header-param 'nonce 'www-authenticate headers))
     225        (test "opaque"
     226              "5ccc069c403ebaf9f0171e9517f40e41"
     227              (header-param 'opaque 'www-authenticate headers))
     228        (test "missing stale value"
     229              #f
     230              (header-param 'stale 'www-authenticate headers)))
     231      (let ((headers (test-read-headers "WWW-Authenticate: Digest domain=\"/example http://foo.com/bar\", stale=TRUE")))
     232        (test "domains"
     233              '("/example" "http://foo.com/bar")
     234              (map uri->string
     235                   (header-param 'domain 'www-authenticate headers)))
     236        (test "stale"
     237              #t
     238              (header-param 'stale 'www-authenticate headers)))
     239      (let ((headers (test-read-headers "WWW-Authenticate: Digest stale=whatever")))
     240        (test "non-true stale value"
     241              #f
     242              (header-param 'stale 'www-authenticate headers)))))
    201243 
    202244  (test-group "pragma-parser"
Note: See TracChangeset for help on using the changeset viewer.