Changeset 11916 in project


Ignore:
Timestamp:
09/07/08 13:38:04 (13 years ago)
Author:
sjamaan
Message:

Add etag-unparser and split out token unparsing from string quoting

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

Legend:

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

    r11914 r11916  
    323323          (loop (cdr params) (if str (cons str results) results))))))
    324324
     325(define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
     326
     327(define quote-string
     328  (let ((smap (map (lambda (c)
     329                     (cons (string c)
     330                           (string-append "\\" (string c))))
     331                   (char-set->list must-be-quoted-chars))))
     332    (lambda (string)
     333      (let ((error-chars (char-set #\newline)))
     334        (if (string-any error-chars string)
     335            (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
     336                                   'unencoded-header 'value string)
     337            (string-append "\"" (string-translate* string smap) "\""))))))
     338
    325339(define unparse-token
    326   (let* ((must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
    327          (trigger-quoting-chars (char-set-union
     340  (let* ((trigger-quoting-chars (char-set-union
    328341                                 (char-set-adjoin must-be-quoted-chars #\, #\; #\=)
    329                                  char-set:blank))
    330          (error-chars (char-set #\newline))
    331          (smap (map (lambda (c)
    332                       (cons (string c)
    333                             (string-append "\\" (string c))))
    334                     (char-set->list must-be-quoted-chars))))
     342                                 char-set:blank)))
    335343   (lambda (token)
    336      (cond
    337       ((string-any error-chars token)
    338        (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
    339                               'unencoded-header 'value token))
    340       ((string-any trigger-quoting-chars token)
    341        (string-append "\"" (string-translate* token smap) "\""))
    342       (else token)))))
     344     (if (string-any trigger-quoting-chars token)
     345         (quote-string token)
     346         token))))
    343347
    344348;; There's no need to make a specific header unparser for every header type.
     
    369373                                 parameter-unparsers))
    370374                result))))))
     375
     376(define (etag-unparser header-name header-contents)
     377  (let ((contents (get-value (car header-contents))))
     378   (sprintf "~A: ~A\r\n"
     379            (header-name->string header-name)
     380            (string-append
     381             (if (eq? 'weak (car contents)) "W/" "")
     382             (if (string-prefix? "W/" (cdr contents))
     383                 (quote-string (cdr contents))
     384                 (unparse-token (cdr contents)))))))
  • release/4/intarweb/trunk/intarweb.scm

    r11914 r11916  
    6464   get-quality get-value get-params get-param
    6565   natnum-parser symbol-parser-ci symbol-parser
    66    unparse-token default-header-unparser
     66   quote-string unparse-token default-header-unparser etag-unparser
    6767   )
    6868
     
    351351(define header-unparsers
    352352  (make-parameter
    353    `()))
     353   `((etag . ,etag-unparser))))
    354354
    355355(define (unparse-headers headers out)
  • release/4/intarweb/trunk/tests/run.scm

    r11914 r11916  
    326326                                              (mumble . mutter)
    327327                                              (blah . #t)
    328                                               (feh . #f)))))))))
     328                                              (feh . #f))))))))
     329  (test-group "Entity-tag unparser"
     330    (test "Weak tag"
     331          "Etag: W/blah\r\n"
     332          (test-unparse-headers `((etag (weak . "blah")))))
     333    (test "Strong tag"
     334          "Etag: blah\r\n"
     335          (test-unparse-headers `((etag (strong . "blah")))))
     336    (test "Strong tag starting with W/"
     337          "Etag: \"W/blah\"\r\n"
     338          (test-unparse-headers `((etag (strong . "W/blah")))))))
    329339
    330340(define (test-read-request str)
Note: See TracChangeset for help on using the changeset viewer.