Changeset 33950 in project

04/08/17 17:21:51 (21 months ago)

intarweb: Add support for "parsing" and unparsing of raw values

3 edited


  • release/4/intarweb/trunk/header-parsers.scm

    r33948 r33950  
    4949  (cond ((assq param (vector-ref contents 1)) => cdr)
    5050        (else default)))
     52(define (get-no-newline-value header)
     53  (let ((v (get-value header)))
     54    (when (string-index v #\newline)
     55      ;; There's duplication with quote-string error here...
     56      (signal-http-condition
     57       'raw-value
     58       (conc "Unencoded newline in header contents! "
     59             "Please encode the newline in a way "
     60             "appropriate for this header")
     61       (list string) 'unencoded-header 'value string))
     62    v))
    5264;;;; Header parsers
    316328    (max 0.0 (min 1.0 imprecise))))
    318 ;; Just put all header strings in a list, so we can pass it on
     330;; Just put all header strings in a list, so we can pass it on.
    319331;; Make no assumptions about the contents (only value, don't try to parse params)
    320332;; This is different from (multiple (without-params generic-header-parser))
    321 ;; because this does not assume it can split up comma-separated values
     333;; because this does not assume it can split up comma-separated values.
     334;; It also will ensure that the value is raw,
    322335(define (unknown-header-parser contents)
    323   (list (vector contents '())))
     336  (list (vector contents 'raw)))
    325338(define symbol-subparser
  • release/4/intarweb/trunk/intarweb.scm

    r33945 r33950  
    175175      (else (cons (car h) (loop (cdr h))))))))
     177;; Check that the header values are valid vectors, and that if there
     178;; is a raw value, there is only one value at all.
     179(define (check-header-values loc name contents)
     180  (let lp ((mode 'unknown) (todo contents))
     181    (let ((head (car todo)))
     182      (if (not (and (vector? head) (= 2 (vector-length head))))
     183          (signal-http-condition
     184           loc "header values must be vectors of length 2"
     185           (list name contents) 'header-value)
     186          (let ((type (if (eq? (get-params head) 'raw) 'raw 'cooked)))
     187            (unless (or (eq? mode 'unknown) (eq? mode type))
     188              (signal-http-condition
     189               loc "When using raw headers, all values must be raw"
     190               (list name contents) 'header-value)
     191              (lp type (cdr todo))))))))
    177193;; XXX: Do we need these replace procedures in the exports list?  It
    178194;; looks like we can use update everywhere.
    179195(define (replace-header-contents! name contents headers)
     196  (check-header-values 'replace-header-contents! name contents)
    180197  (let loop ((h (headers-v headers)))
    181198    (cond
    191208(define (replace-header-contents name contents headers)
     209  (check-header-values 'replace-header-contents! name contents)
    192210  (make-headers
    193211   (let loop ((h (headers-v headers)))
    676694(define (unparse-header header-name header-value)
    677   (cond ((assq header-name (header-unparsers))
     695  (cond ((and (not (null? header-value))
     696              (eq? 'raw (get-params (car header-value))))
     697         (map get-no-newline-value header-value))
     698        ((assq header-name (header-unparsers))
    678699         => (lambda (unparser) ((cdr unparser) header-value)))
    679700        (else (default-header-unparser header-value))))
    708729                    'unparser unparse
    709730                    'original-exn exn)))
    710            (for-each (lambda (value)
    711                        ;; Verify there's no \r\n or \r or \n in value?
    712                        (display (string-append name-s ": " value "\r\n") out))
    713                      (unparse contents)))))
     731           (let ((lines (if (and (not (null? contents))
     732                                 (eq? 'raw (get-params (car contents))))
     733                            (map get-no-newline-value contents)
     734                            (unparse contents))))
     735             (for-each (lambda (value)
     736                         ;; Verify there's no \r\n or \r or \n in value?
     737                         (display (string-append name-s ": " value "\r\n") out))
     738                       lines)))))
    714739     (headers-v headers))))
  • release/4/intarweb/trunk/tests/run.scm

    r33896 r33950  
    7070   (let ((headers (test-read-headers "unknown: foo, bar\r\nunknown: blah\r\n\r\n")))
    7171     (test "Unknown headers are not parsed and put into lists"
    72            '("foo, bar" "blah") (header-values 'unknown headers))))
     72           '("foo, bar" "blah") (header-values 'unknown headers))
     73     (test "Unknown headers get raw instead of a parameter list"
     74           'raw (header-params 'unknown headers))))
    7375  (test-group "miscellaneous header stuff"
    7476    (parameterize ((header-parsers `((foo . ,(multiple identity))
    632634                                              (mumble . mutter)
    633635                                              (blah . #t)
    634                                               (feh . #f))))))))
     636                                              (feh . #f)))))))
     637    (test "Raw headers are unparsed as-is"
     638          "Foo: bla bla; whatever \"ohai\"\r\n"
     639          (test-unparse-headers `((foo #("bla bla; whatever \"ohai\"" raw)))))
     640    (test "Raw headers are unparsed as-is for known headers, too"
     641          "Etag: \"hi there\r\n" ;; unclosed quote is intentional here
     642          (test-unparse-headers `((etag #("\"hi there" raw)))))
     643    (test-error* "Embedded newlines in raw headers also throw an error"
     644                 (exn http unencoded-header)
     645                 (test-unparse-headers `((foo #("bar\n\x01qux" raw))))))
    635646  (test-group "etag unparser"
    636647    (test "Weak tag"
Note: See TracChangeset for help on using the changeset viewer.