Changeset 14836 in project


Ignore:
Timestamp:
05/30/09 17:27:21 (10 years ago)
Author:
sjamaan
Message:

Rework parsers a little so they can return lists of values instead of headers. It makes more sense this way and makes the code a bit shorter - and paves the way for more changes to come

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

Legend:

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

    r14835 r14836  
    3131
    3232;;;; Header parsers
     33
     34(define (single subparser #!optional (parameter-subparsers '()))
     35  (lambda (contents)
     36    (list ((with-params subparser parameter-subparsers) contents))))
     37
     38(define (multiple subparser #!optional (parameter-subparsers '()))
     39  (lambda (contents)
     40    (map (with-params subparser parameter-subparsers)
     41         (split-multi-header contents))))
    3342
    3443;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
     
    168177      type+params)))
    169178
    170 (define (multiple subparser #!optional (parameter-subparsers '()))
    171   (lambda (name entries headers)
    172     (fold (lambda (entry headers)
    173             (update-header-contents!
    174              name
    175              (list ((with-params subparser parameter-subparsers) entry))
    176              headers))
    177           headers
    178           (split-multi-header entries))))
    179 
    180 (define (single subparser #!optional (parameter-subparsers '()))
    181   (lambda (name contents headers)
    182     (replace-header-contents!
    183      name
    184      (list ((with-params subparser parameter-subparsers) contents))
    185      headers)))
    186 
    187 (define (make-key/values-subparser key/value-subparsers)
     179(define (make-key/value-subparser key/value-subparsers)
    188180  (lambda (k/v)
    189181    ;; We're abusing parse-parameters here to read value
     
    191183    (receive (key+value pos)
    192184      (parse-parameters k/v 0 key/value-subparsers)
    193       (car key+value))))
     185      (vector (car key+value) '())))) ;; There's only one key/value pair
    194186
    195187(foreign-declare "#include <locale.h>")
     
    263255;; This is different from (multiple (without-params generic-header-parser))
    264256;; because this does not assume it can split up comma-separated values
    265 (define (unknown-header-parser name contents headers)
    266   (update-header-contents! name (list (vector contents '())) headers))
     257(define (unknown-header-parser contents)
     258  (list (vector contents '())))
    267259
    268260(define symbol-subparser
     
    302294;; want tokens, they know how to have it. OTOH, it would mean much
    303295;; more code for all the parsers as they need to tokenize more...
    304 (define (entity-tag-parser name contents headers)
     296(define (entity-tag-parser contents)
    305297  (let ((contents (string-trim-both contents)))
    306     (replace-header-contents!
    307      name
    308      (list (if (string-prefix? "W/" contents)
    309                (vector `(weak . ,(parse-token contents 2 (char-set))) '())
    310                (vector `(strong . ,(parse-token contents 0 (char-set))) '())))
    311      headers)))
     298    (list (vector
     299           (if (string-prefix? "W/" contents)
     300               `(weak . ,(parse-token contents 2 char-set:whitespace))
     301               `(strong . ,(parse-token contents 0 char-set:whitespace)))
     302           '()))))
     303
     304;; Used for both if-match and if-none-match
     305;; This is either a wilcard ('*') or several entities
     306(define (if-match-parser contents)
     307  (let ((contents (string-trim-both contents)))
     308    (if (string=? "*" contents)
     309        (list (vector '* '()))
     310        (let loop ((pos 0)
     311                   (etags '()))
     312          (let ((weak (string-prefix? "W/" contents 0 2 pos)))
     313            (receive (etag newpos)
     314              (parse-token contents (+ pos (if weak 2 0)) char-set:whitespace)
     315              (let ((newpos (string-skip contents char-set:whitespace newpos))
     316                    (value (and etag (vector (cons (if weak 'weak 'strong)
     317                                                   etag) '()))))
     318               (if value
     319                   (if newpos
     320                       (loop newpos (cons value etags))
     321                       (reverse! (cons value etags)))
     322                   (reverse! etags)))))))))
    312323
    313324;; ( <product>[/<version>] [<comment>] )+
    314325;; This parser is a full parser because parse-token cannot handle
    315326;; comments yet... (if a ; is in a comment, it breaks down)
    316 (define (product-parser name contents headers)
    317   (replace-header-contents!
    318    name
    319    (let loop ((start-pos 0)
    320               (products '()))
    321      (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\()))
    322                    ((version pos2) (parse-token contents pos ; (add1 pos)
    323                                                 (char-set-union (char-set #\()
    324                                                                 char-set:whitespace)))
    325                    ((comment pos3) (parse-comment contents pos2))
    326                    ;; Ugh
    327                    ((real-version) (and version (not (string-null? version)) (string-trim version #\/))))
    328        (if product
    329            (loop pos3 (cons (list product real-version comment) products))
    330            (list (vector (reverse products) '())))))
    331    headers))
     327(define (product-parser contents)
     328  (let loop ((start-pos 0)
     329             (products '()))
     330    (let*-values (((product pos) (parse-token contents start-pos (char-set #\/ #\()))
     331                  ((version pos2) (parse-token contents pos ; (add1 pos)
     332                                               (char-set-union (char-set #\()
     333                                                               char-set:whitespace)))
     334                  ((comment pos3) (parse-comment contents pos2))
     335                  ;; Ugh
     336                  ((real-version) (and version (not (string-null? version)) (string-trim version #\/))))
     337      (if product
     338          (loop pos3 (cons (list product real-version comment) products))
     339          (list (vector (reverse products) '()))))))
    332340
    333341;;;; MAJOR TODOs
     
    336344
    337345;; Either an entity-tag or a http-date
    338 (define (if-range-parser name contents header)
     346(define (if-range-parser contents)
    339347  (let ((http-date ((with-params http-date-string->time '()) contents)))
    340348    (if (get-value http-date)
    341         (replace-header-contents! name (list http-date) header)
    342         (entity-tag-parser name contents header))))
     349        (list http-date)
     350        (entity-tag-parser contents))))
    343351
    344352;; Either delta-seconds or http-date
     
    347355;; Tricky - see 2616 14.45
    348356;; We probably shouldn't try to do too much parsing here
    349 (define via-parser (multiple identity))
     357(define via-parser split-multi-header)
    350358
    351359;; Tricky - see 2616 14.46
    352 (define warning-parser (multiple identity))
     360(define warning-parser split-multi-header)
    353361;;;; END MAJOR TODOs
    354362
     
    366374                            (max-age . ,string->number)
    367375                            (version . ,string->number))))
    368     (lambda (name contents headers)
     376    (lambda (contents)
    369377      (if (old-style-cookie? contents)
    370           (update-header-contents!
    371            name
    372            (list ((with-params key/value-subparser param-subparsers) contents))
    373            headers)
    374           ((multiple key/value-subparser param-subparsers) name contents headers)))))
     378          (list ((with-params key/value-subparser param-subparsers) contents))
     379          (map (with-params key/value-subparser param-subparsers)
     380               (split-multi-header contents))))))
    375381
    376382(define cache-control-parser
     
    378384                    (map (compose string->symbol string-trim-both)
    379385                         (string-split str ",")))))
    380     (multiple
    381      (make-key/values-subparser `((max-age . ,natnum-subparser)
    382                                   (s-maxage . ,natnum-subparser)
    383                                   (max-stale . ,natnum-subparser)
    384                                   (min-fresh . ,natnum-subparser)
    385                                   (private . ,splitter)
    386                                   (no-cache . ,splitter))))))
    387 
    388 (define pragma-parser
    389   (multiple (make-key/values-subparser `())))
    390 
    391 (define te-parser
    392   (multiple (make-key/values-subparser `((q . ,quality-subparser)))))
     386    (lambda (contents)
     387      (map
     388       (make-key/value-subparser `((max-age . ,natnum-subparser)
     389                                   (s-maxage . ,natnum-subparser)
     390                                   (max-stale . ,natnum-subparser)
     391                                   (min-fresh . ,natnum-subparser)
     392                                   (private . ,splitter)
     393                                   (no-cache . ,splitter)))
     394       (split-multi-header contents)))))
     395
     396(define (pragma-parser contents)
     397  (map (make-key/value-subparser `()) (split-multi-header contents)))
     398
     399(define (te-parser contents)
     400  (map (make-key/value-subparser `((q . ,quality-subparser)))
     401       (split-multi-header contents)))
    393402
    394403;; Cookie headers are also braindead: there can be several cookies in one header,
     
    400409;;
    401410;; This code is a bit of a hack in the way it abuses parse-parameters
    402 (define (cookie-parser name value headers)
     411(define (cookie-parser contents)
    403412  ;; Get all attributes (dollar-prefixed params) and remaining cookies & params
    404413  (define (split-attribs pairs)
     
    407416          pairs))
    408417  (receive (params pos)
    409     (parse-parameters value 0 `(($version . ,string->number)
    410                                ($port . ,string->number)))
     418    (parse-parameters contents 0 `(($version . ,string->number)
     419                                   ($port . ,string->number)))
    411420    (receive (global-attrs remaining)
    412421      (split-attribs params)
     
    414423                 (cookies '()))
    415424        (if (null? remaining)
    416             (update-header-contents! name (reverse cookies) headers)
     425            (reverse cookies)
    417426            (let ((cookie (cons (symbol->string (caar remaining))
    418427                                (cdar remaining)))
  • release/4/intarweb/trunk/intarweb.scm

    r14574 r14836  
    6767   split-multi-header parse-token parse-comment
    6868   parse-parameters parse-value+parameters multiple single
    69    make-key/values-subparser
     69   make-key/value-subparser
    7070   
    7171   rfc1123-string->time rfc850-string->time asctime-string->time
     
    281281     (date . ,(single http-date-subparser))
    282282     (etag . ,entity-tag-parser)
    283      (expect . ,(single (make-key/values-subparser '())))
     283     (expect . ,(single (make-key/value-subparser '())))
    284284     (expires . ,(single http-date-subparser))
    285285     (from . ,(multiple mailbox-subparser))
    286286     (host . ,(single host/port-subparser))
    287      ;; XXX FIXME
    288      (if-match . ,(multiple entity-tag-parser))
     287     (if-match . ,if-match-parser)
    289288     (if-modified-since . ,(single http-date-subparser))
    290      ;; XXX FIXME
    291      (if-none-match . ,(multiple entity-tag-parser))
     289     (if-none-match . ,if-match-parser)
    292290     (if-range . ,if-range-parser)
    293291     (if-unmodified-since . ,(single http-date-subparser))
     
    317315     )))
    318316
    319 ;; The parser is supposed to return the new (possibly modified) headers list
    320 (define (parse-header name contents headers)
     317;; The parser is supposed to return a list of header values for its header
     318(define (parse-header name contents)
    321319  (let* ((default unknown-header-parser)
    322320         (parser (alist-ref name (header-parsers) eq? default)))
    323     (parser name contents headers)))
     321    (parser contents)))
    324322
    325323(define (parse-header-line line headers)
     
    328326              (header-name (http-name->symbol (string-take line colon-idx)))
    329327              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
    330              (parse-header header-name contents headers))
     328             (update-header-contents!
     329              header-name (parse-header header-name contents) headers))
    331330   (signal-http-condition "Bad header line" 'header-error 'contents line)))
    332331
  • release/4/intarweb/trunk/tests/run.scm

    r14574 r14836  
    206206              '(strong . "W/bar")
    207207              (header-value 'etag headers))))
     208
     209  (test-group "if-match parser"
     210    (let ((headers (test-read-headers "If-match: foo")))
     211      (test "Strong etag"
     212            '(strong . "foo")
     213            (header-value 'if-match headers)))
     214    (let ((headers (test-read-headers "If-match: W/foo")))
     215      (test "Weak etag"
     216            '(weak . "foo")
     217            (header-value 'if-match headers)))
     218    (let ((headers (test-read-headers "If-match: W/foo bar")))
     219      (test "Multiple etags"
     220            '((weak . "foo") (strong . "bar"))
     221            (header-values 'if-match headers)))
     222    (let ((headers (test-read-headers "If-match: *")))
     223      (test "Wildcard"
     224            '*
     225            (header-value 'if-match headers))))
    208226
    209227  (test-group "http-date-parser"
Note: See TracChangeset for help on using the changeset viewer.