Changeset 11722 in project


Ignore:
Timestamp:
08/23/08 15:44:22 (13 years ago)
Author:
sjamaan
Message:

Remove value+params struct, normalize to vectors

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

Legend:

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

    r11715 r11722  
    1414  0)
    1515
    16 (define-record value+params value params)
    17 
    18 ;; XXX: Define a procedure that's a combination of this and get-header-contents
    19 (define get-value value+params-value)
    20 (define (get-values headers) (map value+params-value headers))
     16;; Get the raw contents of a header
     17(define (get-header-contents name headers #!optional (default #f))
     18  (alist-ref name headers eq? default))
     19
     20;; Get all values of a header
     21(define (get-header-values header-name headers)
     22  (map (cut vector-ref <> 0) (get-header-contents header-name headers '())))
     23
     24;; Get the value of a header which is an alist
     25;; Example: header = ((foo . bar) (qux . mooh)), header-list-ref foo
     26;; will return bar.  (the header itself is encoded in a param+value
    2127(define (header-list-ref value headers #!optional (equal? eq?))
    2228  (find (lambda (h) (equal? (car (get-value h)) value)) headers))
    2329
     30;; Get the value from one header entry
     31(define get-value (cut vector-ref <> 0))
     32
     33;; Get all params from one header entry
     34(define get-params (cut vector-ref <> 1))
     35
     36;; Get one specific parameter from one header entry
    2437(define (get-param param contents)
    25   (alist-ref param (value+params-params contents) eq?))
    26 
     38  (alist-ref param (vector-ref contents 1) eq?))
     39
     40;; Get-param, except if no quality is present return 1
    2741(define (get-quality header-contents)
    2842  (or (get-param 'q header-contents) 1.0))
     
    90104;; because this does not assume it can split up comma-separated values
    91105(define (unknown-header-parser name contents headers)
    92   (update-header-contents! name (list (make-value+params contents '())) headers))
     106  (update-header-contents! name (list (vector contents '())) headers))
    93107
    94108(define (read-tokens string start-pos . char-sets)
     
    131145        (receive (params pos)
    132146          (read-parameters string (add1 pos) param-parsers)
    133           (values (make-value+params (value-parser value) params)
    134                   pos)))))
     147          (values (vector (value-parser value) params) pos)))))
    135148
    136149(define (with-params value-parser parameter-parsers)
     
    283296                (split-attribs params)
    284297                (let* ((all-attrs (append global-attrs local-attrs))
    285                        (result (make-value+params
    286                                 cookie all-attrs)))
     298                       (result (vector cookie all-attrs)))
    287299                  (loop rest (cons result cookies))))))))))
    288300
     
    317329                 (header-name->string header-name)
    318330                 (string-join result ", "))
    319         (let* ((contents (value+params-value (car headers)))
     331        (let* ((contents (get-value (car headers)))
    320332               (value (if (pair? contents) ; alist?
    321333                          (conc (car contents) "=" (cdr contents))
     
    326338                (string-append
    327339                 (unparse-token value)
    328                  (unparse-params (value+params-params (car headers))
     340                 (unparse-params (get-params (car headers))
    329341                                 parameter-unparsers))
    330342                result))))))
  • release/4/intarweb/trunk/intarweb.scm

    r11710 r11722  
    4040  (read-line-limit replace-header-contents replace-header-contents!
    4141   update-header-contents update-header-contents! make-headers single-headers
    42    string->header-name header-name->string
    43    header-parsers get-header-contents
     42   string->header-name header-name->string header-parsers
    4443   http-0.9-request-parser http-1.x-request-parser
    4544   make-request request? request-major-version request-minor-version
     
    5150
    5251   ;; http-header-parsers
    53    split-multi-header unknown-header-parser single multiple
    54    read-token get-quality get-param get-value get-values header-list-ref
     52   split-multi-header unknown-header-parser single multiple read-token
     53   get-header-contents get-header-values
     54   get-quality get-value get-params get-param header-list-ref
    5555   natnum-parser symbol-parser-ci symbol-parser
    56    make-value+params value+params? value+params-value value+params-params
    5756   default-header-unparser
    5857   )
     
    10099           (car h)
    101100           (map (lambda (v)
    102                   (if (vector? v)
    103                       (make-value+params (vector-ref v 0) (vector-ref v 1))
    104                       (make-value+params v '())))
     101                  (if (vector? v) v (vector v '()))) ; normalize to vector
    105102                (cdr h))
    106103           new-headers))
     
    174171     )))
    175172
    176 (define (get-header-contents name headers #!optional (default #f))
    177   (alist-ref name headers eq? default))
    178 
    179173;; The parser is supposed to return the new (possibly modified) headers list
    180174(define (parse-header name contents headers)
  • release/4/intarweb/trunk/tests/run.scm

    r11715 r11722  
    8080     (let ((headers (test-read-headers "foo: bar\r\nqux:\t   \tmooh\t   \r\n\r\n")))
    8181       (test "Basic test"
    82              '("bar") (get-values (get-header-contents 'foo headers)))
     82             '("bar") (get-header-values 'foo headers))
    8383       ;; RFC 2616 4.2
    8484       (test "Extra spaces are ignored"
    85              '("mooh") (get-values (get-header-contents 'qux headers))))
     85             '("mooh") (get-header-values 'qux headers)))
    8686     (let ((headers (test-read-headers "foo: bar\r\n qux: mooh\r\nquux: mumble\r\n\r\n")))
    8787       ;; RFC 2616 2.2
    8888       (test "Continuation chars"
    89              '("bar qux: mooh") (get-values (get-header-contents 'foo headers))))
     89             '("bar qux: mooh") (get-header-values 'foo headers)))
    9090     ;; Not in RFC but common behaviour - also, robustness principle
    9191     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\n")))
    9292       (test "Multiple headers for singular header types discarded"
    93              '("qux") (get-values (get-header-contents 'foo headers))))))
     93             '("qux") (get-header-values 'foo headers)))))
    9494  ;; All this RFC 2616 4.2
    9595  (test-group "Multi-headers"
     
    9797     (let ((headers (test-read-headers "foo: bar\r\nfoo: qux\r\nquux: mumble\r\n\r\n")))
    9898       (test "Multiple headers"
    99              '("bar" "qux") (get-values (get-header-contents 'foo headers))))
     99             '("bar" "qux") (get-header-values 'foo headers)))
    100100     (let ((headers (test-read-headers "Foo: bar\r\nFoO: qux\r\nquux: mumble\r\n\r\n")))
    101101       (test "Multiple headers: case insensitivity"
    102              '("bar" "qux") (get-values (get-header-contents 'foo headers))))
     102             '("bar" "qux") (get-header-values 'foo headers)))
    103103     (let ((headers (test-read-headers "foo: bar, qux\r\nquux: mumble\r\n\r\n")))
    104104       (test "Comma-separated headers"
    105              '("bar" "qux") (get-values (get-header-contents 'foo headers))))
     105             '("bar" "qux") (get-header-values 'foo headers)))
    106106     (let ((headers (test-read-headers "foo: \"ba\\\"r, qux\"\r\nfoo: mooh\r\n\r\n")))
    107107       (test "Quoted headers"
    108              '("ba\"r, qux" "mooh") (get-values (get-header-contents 'foo headers)))))
     108             '("ba\"r, qux" "mooh") (get-header-values 'foo headers))))
    109109   ;; RFC 2616 4.5
    110110   ;; "Unrecognized header fields are treated as entity-header fields."
     
    115115   (let ((headers (test-read-headers "unknown: foo, bar\r\nunknown: blah\r\n\r\n")))
    116116     (test "Unknown headers are not parsed and put into lists"
    117            '("foo, bar" "blah") (get-values (get-header-contents 'unknown headers)))))
     117           '("foo, bar" "blah") (get-header-values 'unknown headers))))
    118118  (test-group "Miscellaneous"
    119119    (test-error "Missing header contents" (test-read-headers "foo\r\n\r\n"))))
     
    146146    (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
    147147      (test "Case-insensitive"
    148             '(foo) (get-values (get-header-contents 'accept-ranges headers)))))
     148            '(foo) (get-header-values 'accept-ranges headers))))
    149149 
    150150  (test-group "Symbol-parser"
    151151    (let* ((headers (test-read-headers "Allow: FoO, foo")))
    152152      (test "Case-sensitive"
    153             '(FoO foo) (get-values (get-header-contents 'allow headers)))))
     153            '(FoO foo) (get-header-values 'allow headers))))
    154154
    155155  (test-group "Natnum-parser"
     
    299299  (test "Simple test"
    300300        `(bar qux)
    301         (get-values
    302          (get-header-contents 'foo (make-headers `((foo bar qux))))))
     301        (get-header-values 'foo (make-headers `((foo bar qux)))))
    303302  (test "Multi headers are folded"
    304303        `(bar qux)
    305         (get-values
    306          (get-header-contents 'foo (make-headers `((foo bar)
    307                                                    (foo qux))))))
     304        (get-header-values 'foo (make-headers `((foo bar)
     305                                                  (foo qux)))))
    308306  (test "Single headers are unique"
    309307        `(qux)
    310         (get-values
    311          (get-header-contents 'foo (parameterize ((single-headers '(foo)))
    312                                      (make-headers `((foo bar)
    313                                                      (foo qux)))))))
     308        (get-header-values 'foo (parameterize ((single-headers '(foo)))
     309                                    (make-headers `((foo bar)
     310                                                    (foo qux))))))
    314311  (test "Extra single headers are ignored"
    315312        `(qux)
    316         (get-values
    317          (get-header-contents 'foo (parameterize ((single-headers '(foo)))
    318                                      (make-headers `((foo bar qux)))))))
     313        (get-header-values 'foo (parameterize ((single-headers '(foo)))
     314                                    (make-headers `((foo bar qux))))))
    319315  (test "Parameters"
    320316        `((bar . qux))
    321         (value+params-params
     317        (get-params
    322318         (car (get-header-contents 'foo (make-headers `((foo #(mooh ((bar . qux))))))))))
    323319  (test "Multi headers are folded into old headers"
    324320        `(bar qux)
    325         (get-values
    326          (get-header-contents 'foo (make-headers `((foo qux))
    327                                                  (make-headers `((foo bar))))))))
     321        (get-header-values 'foo (make-headers `((foo qux))
     322                                                (make-headers `((foo bar)))))))
    328323
    329324(define (test-unparse-headers h)
     
    356351                                              (feh . #f)))))))))
    357352
     353;(define (test-write-response ))
     354
     355#;(test-group "write-response"
     356  (test-group "HTTP/0.9"
     357    (test ""
     358          ())))
     359
    358360;; TODO:
    359361;; - Implement comments parsing (better: a sane parsing system!)
Note: See TracChangeset for help on using the changeset viewer.