Changeset 14574 in project


Ignore:
Timestamp:
05/09/09 18:33:57 (10 years ago)
Author:
sjamaan
Message:

Rearrange code so it has a more logical source order. Rename all subparsers so they end in -subparser (finding bugs in the process). Fix export list

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

Legend:

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

    r14572 r14574  
    1 ;; Change the accuracy of a number to 'digits' number of digits to the
    2 ;; right of the decimal point.
    3 (define (chop-number num digits)
    4   (let ((factor (expt 10 digits)))
    5     (/ (round (* num factor)) factor)))
    6 
    7 (define (quality-parser str)
    8   ;; Anything that's not a number is seen as if the value is missing, hence 1.0
    9   (let* ((num       (or (string->number str) 1.0))
    10          (imprecise (chop-number num 3)))
    11     (max 0.0 (min 1.0 imprecise))))
    12 
    13 (foreign-declare "#include <locale.h>")
    14 
    15 (define setlocale (foreign-lambda c-string setlocale int c-string))
    16 
    17 (define-foreign-variable LC_TIME int)
    18 
    19 (define-syntax let-locale
    20   (syntax-rules ()
    21     ((let-locale ((cat val) ...) body ...)
    22      (let ((backup '()))
    23        (dynamic-wind
    24            (lambda () (set! backup '((cat . ,(setlocale cat val)) ...)))
    25            (lambda () body ...)
    26            (lambda () (setlocale cat (alist-ref backup 'cat)) ...))))))
    27 
    28 (define (rfc1123-string->time str)
    29   (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat), [0-9]{2} (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [0-9]{4} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
    30        (let-locale ((LC_TIME "POSIX"))
    31                    (string->time str "%a, %d %b %Y %X GMT"))))
    32 
    33 (define (rfc1123-parser str)
    34   (or (rfc1123-string->time str)
    35       (signal-http-condition "Error parsing RFC 1123 date/time"
    36                              'rfc1123-parser 'value str)))
    37 
    38 (define (rfc850-string->time str)
    39   (and (string-search "(Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday), [0-9]{2}-(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)-[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
    40       (let-locale ((LC_TIME "POSIX"))
    41                   (string->time str "%a, %d-%b-%y %X GMT"))))
    42 
    43 (define (rfc850-parser str)
    44   (or (rfc850-string->time str)
    45       (signal-http-condition "Error parsing RFC850 date/time"
    46                              'asctime-parser 'value str)))
    47 
    48 (define (asctime-string->time str)
    49   (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)  ?[0-9]{1,2} [0-9]{2}:[0-9]{2}:[0-9]{2} [0-9]{4}" str)
    50        (let-locale ((LC_TIME "POSIX"))
    51                    (string->time str "%a %b %d %X %Y"))))
    52 
    53 (define (asctime-parser str)
    54   (or (asctime-string->time str)
    55       (signal-http-condition "Error parsing asctime() date/time"
    56                              'asctime-parser 'value str)))
     1;;;; Header value accessor procedures
    572
    583;; Get the raw contents of a header
     
    8631
    8732;;;; Header parsers
     33
     34;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
     35(define (split-multi-header value)
     36  (let ((len (string-length value)))
     37    (let loop ((result '())
     38               (start-pos 0)   ; Where the current header value starts
     39               (search-pos 0)) ; Where the searching starts
     40      (or (and-let* (((< search-pos len))
     41                     (pos (string-index value (char-set #\, #\") search-pos)))
     42            (if (char=? #\, (string-ref value pos))
     43                (loop (cons (string-copy value start-pos pos) result) (add1 pos) (add1 pos))
     44                (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\"))))
     45                  (loop result start-pos (add1 end-pos)))))
     46          (reverse (cons (string-drop value start-pos) result))))))
     47
     48;; Remove all escape characters from the input, recognising "escaped escapes"
     49(define (unescape str)
     50  (let ((last-char (sub1 (string-length str))))
     51    (let loop ((result "")
     52               (start-pos 0))
     53      (or (and-let* ((pos (string-index str #\\ start-pos)))
     54            (if (= pos last-char)
     55                (string-append result (string-copy str start-pos))
     56                (loop (string-append result (string-copy str start-pos pos)
     57                                     (string-copy str (add1 pos) (+ pos 2)))
     58                      (+ pos 2))))
     59          (string-append result (string-copy str start-pos))))))
    8860
    8961;; Find a matching endpoint for a token, ignoring escaped copies of the token
     
    10173                pos)
    10274            len))))) ; No matching closing symbol?  "Insert" it at the end
    103 
    104 ;; RFC 2616 4.2 says multi-headers are a comma-separated list of tokens
    105 (define (split-multi-header value)
    106   (let ((len (string-length value)))
    107     (let loop ((result '())
    108                (start-pos 0)   ; Where the current header value starts
    109                (search-pos 0)) ; Where the searching starts
    110       (or (and-let* (((< search-pos len))
    111                      (pos (string-index value (char-set #\, #\") search-pos)))
    112             (if (char=? #\, (string-ref value pos))
    113                 (loop (cons (string-copy value start-pos pos) result) (add1 pos) (add1 pos))
    114                 (let ((end-pos (escaped-string-end value (add1 pos) (char-set #\"))))
    115                   (loop result start-pos (add1 end-pos)))))
    116           (reverse (cons (string-drop value start-pos) result))))))
    117 
    118 ;; Remove all escape characters from the input, recognising "escaped escapes"
    119 (define (unescape str)
    120   (let ((last-char (sub1 (string-length str))))
    121     (let loop ((result "")
    122                (start-pos 0))
    123       (or (and-let* ((pos (string-index str #\\ start-pos)))
    124             (if (= pos last-char)
    125                 (string-append result (string-copy str start-pos))
    126                 (loop (string-append result (string-copy str start-pos pos)
    127                                      (string-copy str (add1 pos) (+ pos 2)))
    128                       (+ pos 2))))
    129           (string-append result (string-copy str start-pos))))))
    13075
    13176;; Try to parse a token, starting at the provided offset, up until the
     
    186131        (values #f start-pos))))
    187132
    188 ;; Just put all header strings in a list, so we can pass it on
    189 ;; Make no assumptions about the contents (only value, don't try to parse params)
    190 ;; This is different from (multiple (without-params generic-header-parser))
    191 ;; because this does not assume it can split up comma-separated values
    192 (define (unknown-header-parser name contents headers)
    193   (update-header-contents! name (list (vector contents '())) headers))
    194 
    195 (define (parse-parameters string start-pos param-parsers)
     133(define (parse-parameters string start-pos param-subparsers)
    196134  (let loop ((start-pos start-pos)
    197135             (params '()))
     
    205143                  (parse-token string (add1 pos) (char-set #\;))
    206144                  ;; In case of no value ("foo="), use the empty string as value
    207                   (let ((value ((alist-ref attribute param-parsers eq? identity)
     145                  (let ((value ((alist-ref attribute param-subparsers
     146                                           eq? identity)
    208147                                (or value ""))))
    209148                    (loop (add1 pos) (cons (cons attribute value) params))))
     
    213152          (values (reverse params) pos)))))
    214153
    215 (define (parse-value+parameters string start-pos value-parser param-parsers)
     154(define (parse-value+parameters string start-pos
     155                                value-subparser param-subparsers)
    216156  (receive (value pos)
    217157    (parse-token string start-pos (char-set #\;))
     
    219159        (values #f pos) ;; XXX this is wrong and not expected by the caller!
    220160        (receive (params pos)
    221           (parse-parameters string (add1 pos) param-parsers)
    222           (values (vector (value-parser value) params) pos)))))
    223 
    224 (define (with-params value-parser parameter-parsers)
     161          (parse-parameters string (add1 pos) param-subparsers)
     162          (values (vector (value-subparser value) params) pos)))))
     163
     164(define (with-params value-subparser parameter-subparsers)
    225165  (lambda (entry)
    226166    (receive (type+params pos)
    227       (parse-value+parameters entry 0 value-parser parameter-parsers)
     167      (parse-value+parameters entry 0 value-subparser parameter-subparsers)
    228168      type+params)))
    229169
    230 (define (multiple other-parser #!optional (parameter-parsers '()))
     170(define (multiple subparser #!optional (parameter-subparsers '()))
    231171  (lambda (name entries headers)
    232172    (fold (lambda (entry headers)
    233173            (update-header-contents!
    234174             name
    235              (list ((with-params other-parser parameter-parsers) entry))
     175             (list ((with-params subparser parameter-subparsers) entry))
    236176             headers))
    237177          headers
    238178          (split-multi-header entries))))
    239179
    240 (define (single other-parser #!optional (parameter-parsers '()))
     180(define (single subparser #!optional (parameter-subparsers '()))
    241181  (lambda (name contents headers)
    242182    (replace-header-contents!
    243183     name
    244      (list ((with-params other-parser parameter-parsers) contents))
     184     (list ((with-params subparser parameter-subparsers) contents))
    245185     headers)))
    246186
    247 (define (key/values key/value-parsers)
     187(define (make-key/values-subparser key/value-subparsers)
    248188  (lambda (k/v)
    249189    ;; We're abusing parse-parameters here to read value
    250190    ;; instead of params.  This is weird, but it works :)
    251191    (receive (key+value pos)
    252       (parse-parameters k/v 0 key/value-parsers)
     192      (parse-parameters k/v 0 key/value-subparsers)
    253193      (car key+value))))
    254194
    255 (define symbol-parser-ci
     195(foreign-declare "#include <locale.h>")
     196
     197(define-foreign-variable LC_TIME int)
     198
     199(define setlocale (foreign-lambda c-string setlocale int c-string))
     200
     201(define-syntax let-locale
     202  (syntax-rules ()
     203    ((let-locale ((cat val) ...) body ...)
     204     (let ((backup '())
     205           )
     206       (dynamic-wind
     207           (lambda () (set! backup '((cat . ,(setlocale cat val)) ...)))
     208           (lambda () body ...)
     209           (lambda () (setlocale cat (alist-ref backup 'cat)) ...))))))
     210
     211(define (rfc1123-string->time str)
     212  (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat), [0-9]{2} (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [0-9]{4} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
     213       (let-locale ((LC_TIME "POSIX"))
     214                   (string->time str "%a, %d %b %Y %X GMT"))))
     215
     216(define (rfc850-string->time str)
     217  (and (string-search "(Sunday|Monday|Tuesday|Wednesday|Thursday|Friday|Saturday), [0-9]{2}-(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)-[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2} GMT" str)
     218      (let-locale ((LC_TIME "POSIX"))
     219                  (string->time str "%a, %d-%b-%y %X GMT"))))
     220
     221(define (asctime-string->time str)
     222  (and (string-search "(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)  ?[0-9]{1,2} [0-9]{2}:[0-9]{2}:[0-9]{2} [0-9]{4}" str)
     223       (let-locale ((LC_TIME "POSIX"))
     224                   (string->time str "%a %b %d %X %Y"))))
     225
     226(define http-date-string->time
     227  (disjoin rfc1123-string->time rfc850-string->time asctime-string->time))
     228
     229(define (rfc1123-subparser str)
     230  (or (rfc1123-string->time str)
     231      (signal-http-condition "Error parsing RFC 1123 date/time"
     232                             'rfc1123-subparser 'value str)))
     233
     234(define (rfc850-subparser str)
     235  (or (rfc850-string->time str)
     236      (signal-http-condition "Error parsing RFC850 date/time"
     237                             'asctime-subparser 'value str)))
     238
     239(define (asctime-subparser str)
     240  (or (asctime-string->time str)
     241      (signal-http-condition "Error parsing asctime() date/time"
     242                             'asctime-subparser 'value str)))
     243
     244;; rfc1123-date | rfc850-date | asctime-date
     245(define (http-date-subparser str)
     246  (or (http-date-string->time str)
     247      (signal-http-condition "Error parsing date/time"
     248                             'http-date-subparser 'value str)))
     249
     250;; Change the accuracy of a number to 'digits' number of digits to the
     251;; right of the decimal point.
     252(define (chop-number num digits)
     253  (let ((factor (expt 10 digits)))
     254    (/ (round (* num factor)) factor)))
     255
     256(define (quality-subparser str)
     257  ;; Anything that's not a number is seen as if the value is missing, hence 1.0
     258  (let* ((num       (or (string->number str) 1.0))
     259         (imprecise (chop-number num 3)))
     260    (max 0.0 (min 1.0 imprecise))))
     261
     262;; Just put all header strings in a list, so we can pass it on
     263;; Make no assumptions about the contents (only value, don't try to parse params)
     264;; This is different from (multiple (without-params generic-header-parser))
     265;; because this does not assume it can split up comma-separated values
     266(define (unknown-header-parser name contents headers)
     267  (update-header-contents! name (list (vector contents '())) headers))
     268
     269(define symbol-subparser
     270  (compose string->symbol string-trim-both))
     271
     272(define symbol-subparser-ci
    256273  (compose string->symbol string-trim-both string-downcase))
    257274
    258 (define symbol-parser
    259   (compose string->symbol string-trim-both))
    260 
    261 (define (natnum-parser contents)
     275(define (natnum-subparser contents)
    262276  (let ((num (string->number contents)))
    263277    (if num (inexact->exact (max 0 (round num))) 0)))
    264278
    265 (define (host-parser contents)
     279(define (host/port-subparser contents)
    266280  (let ((idx (string-index-right contents #\:)))
    267281    (if idx
     
    272286        (cons contents 80))))
    273287
    274 ; base64 of 128 bit hex digest as per RFC1864
    275 (define md5-parser base64-decode)
     288; base64 of 128 bit hex digest as per RFC1864 (eg, Content-md5)
     289(define base64-subparser base64-decode)
    276290
    277291;; bytes <start>-<end>/<total>
    278 (define (range-parser s)
     292(define (range-subparser s)
    279293  (and-let* ((parts (string-match "bytes[ \t]+([0-9]+)-([0-9]+)/([0-9]+)" s)))
    280294            (map string->number (drop parts 1))))
    281 
    282 ;; rfc1123-date | rfc850-date | asctime-date
    283 (define (http-date-parser str)
    284   (or (rfc1123-string->time str)
    285       (rfc850-string->time str)
    286       (asctime-string->time str)
    287       (signal-http-condition "Error parsing date/time"
    288                              'http-date-parser 'value str)))
    289295
    290296;; [W/]<string>
     
    328334;;;; MAJOR TODOs
    329335;; RFC1123 mailbox parser - just strings for now
    330 (define mailbox-parser identity)
     336(define mailbox-subparser identity)
    331337
    332338;; Either an entity-tag or a http-date
    333 (define if-range-parser identity)
     339(define (if-range-parser name contents header)
     340  (let ((http-date ((with-params http-date-string->time '()) contents)))
     341    (if (get-value http-date)
     342        (replace-header-contents! name (list http-date) header)
     343        (entity-tag-parser name contents header))))
    334344
    335345;; Either delta-seconds or http-date
    336 (define (retry-after-parser contents)
    337   (if (string-match "[ \t]*[0-9]+[ \t]*" contents)
    338       (natnum-parser contents)
    339       (http-date-parser contents)))
     346(define retry-after-subparser (disjoin http-date-subparser natnum-subparser))
    340347
    341348;; Tricky - see 2616 14.45
     
    347354;;;; END MAJOR TODOs
    348355
    349 (define (key/value-parser str)
     356(define (key/value-subparser str)
    350357  (let ((idx (string-index str #\=)))
    351358    (cons (string-take str idx) (string-drop str (add1 idx)))))
     
    354361;; an embedded comma.  RFC 2109 cookies use Max-Age instead.
    355362(define (old-style-cookie? cookie)
    356   (not (not (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))))
     363  (string-search (regexp "^[^=\"]+=[^;]*;.*expires[[:space:]]*=" #f) cookie))
    357364
    358365(define set-cookie-parser
    359   (let ((param-parsers `((expires . ,rfc850-parser)
    360                          (max-age . ,string->number)
    361                          (version . ,string->number))))
     366  (let ((param-subparsers `((expires . ,rfc850-subparser)
     367                            (max-age . ,string->number)
     368                            (version . ,string->number))))
    362369    (lambda (name contents headers)
    363370      (if (old-style-cookie? contents)
    364371          (update-header-contents!
    365372           name
    366            (list ((with-params key/value-parser param-parsers) contents))
     373           (list ((with-params key/value-subparser param-subparsers) contents))
    367374           headers)
    368           ((multiple key/value-parser param-parsers) name contents headers)))))
     375          ((multiple key/value-subparser param-subparsers) name contents headers)))))
    369376
    370377(define cache-control-parser
     
    373380                         (string-split str ",")))))
    374381    (multiple
    375      (key/values `((max-age . ,natnum-parser)
    376                    (s-maxage . ,natnum-parser)
    377                    (max-stale . ,natnum-parser)
    378                    (min-fresh . ,natnum-parser)
    379                    (private . ,splitter)
    380                    (no-cache . ,splitter))))))
     382     (make-key/values-subparser `((max-age . ,natnum-subparser)
     383                                  (s-maxage . ,natnum-subparser)
     384                                  (max-stale . ,natnum-subparser)
     385                                  (min-fresh . ,natnum-subparser)
     386                                  (private . ,splitter)
     387                                  (no-cache . ,splitter))))))
    381388
    382389(define pragma-parser
    383   (multiple (key/values `())))
     390  (multiple (make-key/values-subparser `())))
    384391
    385392(define te-parser
    386   (multiple (key/values `((q . ,quality-parser)))))
     393  (multiple (make-key/values-subparser `((q . ,quality-subparser)))))
    387394
    388395;; Cookie headers are also braindead: there can be several cookies in one header,
     
    499506         (unparse-token (cdr contents))))))
    500507
    501 (define (host-unparser header-name header-contents)
     508(define (host/port-unparser header-name header-contents)
    502509  (let ((contents (get-value (car header-contents))))
    503510    ;; XXX: urlencode?
  • release/4/intarweb/trunk/intarweb.scm

    r14572 r14574  
    3030; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
    3131; OF THE POSSIBILITY OF SUCH DAMAGE.
    32 ;
    33 ; Please report bugs, suggestions and ideas to the Chicken Trac
    34 ; ticket tracking system (assign tickets to user 'sjamaan'):
    35 ; http://trac.callcc.org
    3632
    3733(provide 'intarweb)
     
    6662
    6763   ;; http-header-parsers
    68    split-multi-header unknown-header-parser single multiple
    69    parse-token parse-comment
    7064   header-contents header-values header-value
    71    get-quality get-value get-params get-param
    72    natnum-parser symbol-parser-ci symbol-parser product-parser
    73    quote-string unparse-token default-header-unparser
    74    entity-tag-unparser product-unparser
     65   get-value get-params get-param get-quality
     66
     67   split-multi-header parse-token parse-comment
     68   parse-parameters parse-value+parameters multiple single
     69   make-key/values-subparser
     70   
     71   rfc1123-string->time rfc850-string->time asctime-string->time
     72   http-date-string->time
     73   rfc1123-subparser rfc850-subparser  asctime-subparser http-date-subparser
     74   quality-subparser unknown-header-parser
     75   symbol-subparser symbol-subparser-ci natnum-subparser
     76   host/port-subparser base64-subparser range-subparser
     77   entity-tag-parser product-parser mailbox-subparser if-range-parser
     78   retry-after-subparser via-parser warning-parser key/value-subparser
     79   set-cookie-parser cache-control-parser pragma-parser te-parser
     80   cookie-parser
     81
     82   unparse-params must-be-quoted-chars quote-string unparse-token
     83   default-header-unparser entity-tag-unparser host/port-unparser
     84   product-unparser rfc1123-unparser
    7585   )
    7686
     
    248258(define header-parsers
    249259  (make-parameter
    250    `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
    251      (accept-charset . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
    252      (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
    253      (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
    254      (accept-ranges . ,(single symbol-parser-ci))
    255      (age . ,(single natnum-parser))
    256      (allow . ,(multiple symbol-parser))
    257      (authorization . ,(single symbol-parser-ci))
     260   `((accept . ,(multiple symbol-subparser-ci
     261                          `((q . ,quality-subparser))))
     262     (accept-charset . ,(multiple symbol-subparser-ci
     263                                  `((q . ,quality-subparser))))
     264     (accept-encoding . ,(multiple symbol-subparser-ci
     265                                   `((q . ,quality-subparser))))
     266     (accept-language . ,(multiple symbol-subparser-ci
     267                                   `((q . ,quality-subparser))))
     268     (accept-ranges . ,(single symbol-subparser-ci))
     269     (age . ,(single natnum-subparser))
     270     (allow . ,(multiple symbol-subparser))
     271     (authorization . ,(single symbol-subparser-ci))
    258272     (cache-control . ,cache-control-parser)
    259      (connection . ,(multiple symbol-parser-ci))
    260      (content-encoding . ,(multiple symbol-parser-ci))
    261      (content-language . ,(multiple symbol-parser-ci))
    262      (content-length . ,(single natnum-parser))
     273     (connection . ,(multiple symbol-subparser-ci))
     274     (content-encoding . ,(multiple symbol-subparser-ci))
     275     (content-language . ,(multiple symbol-subparser-ci))
     276     (content-length . ,(single natnum-subparser))
    263277     (content-location . ,(single normalized-uri))
    264      (content-md5 . ,(single md5-parser))
    265      (content-range . ,(single range-parser))
    266      (content-type . ,(single symbol-parser-ci))
    267      (date . ,(single http-date-parser))
     278     (content-md5 . ,(single base64-subparser))
     279     (content-range . ,(single range-subparser))
     280     (content-type . ,(single symbol-subparser-ci))
     281     (date . ,(single http-date-subparser))
    268282     (etag . ,entity-tag-parser)
    269      (expect . ,(single key/values))
    270      (expires . ,(single http-date-parser))
    271      (from . ,(multiple mailbox-parser))
    272      (host . ,(single host-parser))
     283     (expect . ,(single (make-key/values-subparser '())))
     284     (expires . ,(single http-date-subparser))
     285     (from . ,(multiple mailbox-subparser))
     286     (host . ,(single host/port-subparser))
     287     ;; XXX FIXME
    273288     (if-match . ,(multiple entity-tag-parser))
    274      (if-modified-since . ,(single http-date-parser))
     289     (if-modified-since . ,(single http-date-subparser))
     290     ;; XXX FIXME
    275291     (if-none-match . ,(multiple entity-tag-parser))
    276      (if-range . ,(multiple if-range-parser))
    277      (if-unmodified-since . ,(single http-date-parser))
    278      (last-modified . ,(single http-date-parser))
     292     (if-range . ,if-range-parser)
     293     (if-unmodified-since . ,(single http-date-subparser))
     294     (last-modified . ,(single http-date-subparser))
    279295     (location . ,(single normalized-uri))
    280      (max-forwards . ,(single natnum-parser))
     296     (max-forwards . ,(single natnum-subparser))
    281297     (pragma . ,pragma-parser)
    282      (proxy-authenticate . ,(multiple symbol-parser-ci))
    283      (proxy-authorization . ,(single symbol-parser-ci))
    284      (range . ,range-parser)
     298     (proxy-authenticate . ,(multiple symbol-subparser-ci))
     299     (proxy-authorization . ,(single symbol-subparser-ci))
     300     (range . ,(multiple range-subparser))
    285301     (referer . ,(single normalized-uri))
    286      (retry-after . ,retry-after-parser)
     302     (retry-after . ,(single retry-after-subparser))
    287303     (server . ,product-parser)
    288304     (te . ,te-parser)
    289      (trailer . ,(multiple symbol-parser-ci))
    290      (transfer-encoding . ,(single symbol-parser-ci))
     305     (trailer . ,(multiple symbol-subparser-ci))
     306     (transfer-encoding . ,(single symbol-subparser-ci))
    291307     (upgrade . ,(multiple update-header-contents!))
    292308     (user-agent . ,product-parser)
    293      (vary . ,(multiple symbol-parser-ci))
     309     (vary . ,(multiple symbol-subparser-ci))
    294310     (via . ,via-parser)
    295311     (warning . ,warning-parser)
    296      (www-authenticate . ,(single symbol-parser-ci))
     312     (www-authenticate . ,(single symbol-subparser-ci))
    297313     ;; RFC 2109
    298314     (set-cookie . ,set-cookie-parser)
     
    397413   `((etag . ,entity-tag-unparser)
    398414     (expires . ,rfc1123-unparser)
    399      (host . ,host-unparser)
     415     (host . ,host/port-unparser)
    400416     (if-modified-since . ,rfc1123-unparser)
    401417     (if-unmodified-since . ,rfc1123-unparser)
  • release/4/intarweb/trunk/tests/run.scm

    r14573 r14574  
    8282
    8383(test-group "Specialized header parsers"
    84   (test-group "Host"
     84  (test-group "Host/port"
    8585    (test "Hostname and port"
    8686          '(("foo.example.com" . 8080))
     
    122122            '(FoO foo) (header-values 'allow headers))))
    123123
    124   (test-group "Natnum-parser"
     124  (test-group "Natnum-subparser"
    125125    (parameterize ((single-headers '(foo bar qux mooh))
    126                    (header-parsers `((foo . ,(single natnum-parser))
    127                                      (bar . ,(single natnum-parser))
    128                                      (qux . ,(single natnum-parser))
    129                                      (mooh . ,(single natnum-parser)))))
     126                   (header-parsers `((foo . ,(single natnum-subparser))
     127                                     (bar . ,(single natnum-subparser))
     128                                     (qux . ,(single natnum-subparser))
     129                                     (mooh . ,(single natnum-subparser)))))
    130130     (let ((headers (test-read-headers "Foo: 10\r\nBar: abc\r\nQux: -10\r\nMooh: 1.6")))
    131131       (test "Simple test"
     
    166166            '(must-revalidate . #t) (assq 'must-revalidate (header-values 'cache-control headers)))))
    167167
    168   ;; RFC 2616, 14.15   Related: RFC 1864 (Base64) and RF1321 (MD5)
    169   (test-group "md5-parser"
     168  ;; RFC 2616, 14.15  &  RFC 1864 (Base64)
     169  (test-group "base64-parser"
    170170    (let ((headers (test-read-headers "Content-md5: Q2hlY2sgSW50ZWdyaXR5IQ==")))
    171171      (test "md5 is base64-decoded"
     
    178178            '(500 999 1234)
    179179            (header-value 'content-range headers))))
    180 
    181   (test-group "http-date-parser"
    182     (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
    183       (test "RFC1123 time"
    184             (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
    185             (utc-time->seconds (header-value 'date headers))))
    186     (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
    187       (test "RFC850 time"
    188             (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
    189             (utc-time->seconds (header-value 'date headers))))
    190     (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
    191       (test "asctime time"
    192             (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
    193             (utc-time->seconds (header-value 'date headers)))))
    194180
    195181  (test-group "normalized-uri"
     
    220206              '(strong . "W/bar")
    221207              (header-value 'etag headers))))
     208
     209  (test-group "http-date-parser"
     210    (let ((headers (test-read-headers "Date: Sun, 06 Nov 1994 08:49:37 GMT")))
     211      (test "RFC1123 time"
     212            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     213            (utc-time->seconds (header-value 'date headers))))
     214    (let ((headers (test-read-headers "Date: Sunday, 06-Nov-94 08:49:37 GMT")))
     215      (test "RFC850 time"
     216            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     217            (utc-time->seconds (header-value 'date headers))))
     218    (let ((headers (test-read-headers "Date: Sun Nov  6 08:49:37 1994")))
     219      (test "asctime time"
     220            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     221            (utc-time->seconds (header-value 'date headers)))))
     222
     223  ;; This seems a little excessive.. Maybe find a way to reduce the number
     224  ;; of cases and still have a good representative test?
     225  (test-group "If-Range parser"
     226    (let ((headers (test-read-headers "If-Range: Sun, 06 Nov 1994 08:49:37 GMT")))
     227      (test "RFC1123 time"
     228            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     229            (utc-time->seconds (header-value 'if-range headers))))
     230    (let ((headers (test-read-headers "If-Range: Sunday, 06-Nov-94 08:49:37 GMT")))
     231      (test "RFC850 time"
     232            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     233            (utc-time->seconds (header-value 'if-range headers))))
     234    (let ((headers (test-read-headers "If-Range: Sun Nov  6 08:49:37 1994")))
     235      (test "asctime time"
     236            (utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))
     237            (utc-time->seconds (header-value 'if-range headers))))
     238    (let ((headers (test-read-headers "If-Range: \"foo\"")))
     239      (test "Strong Etag"
     240            '(strong . "foo")
     241            (header-value 'if-range headers)))
     242    (let ((headers (test-read-headers "If-Range: W/\"bar\"")))
     243      (test "Weak Etag"
     244            '(weak . "bar")
     245            (header-value 'if-range headers)))
     246    (let ((headers (test-read-headers "If-Range: \"\"")))
     247      (test "Empty Etag"
     248            '(strong . "")
     249            (header-value 'if-range headers)))
     250    (let ((headers (test-read-headers "If-Range: \"W/bar\"")))
     251        (test "Strong Etag, containing W/ prefix"
     252              '(strong . "W/bar")
     253              (header-value 'if-range headers)))    )
    222254
    223255  (test-group "Product parser"
     
    383415          (test-unparse-headers
    384416           `((if-modified-since #(#(37 49 08 06 10 94 0 310 #f 0) ()))))))
    385   (test-group "Host unparser"
     417  (test-group "Host/port unparser"
    386418    (test "Default port is 80, left out"
    387419          "Host: foo.example.com\r\n"
     
    629661;; - Add parsing capability for quoted-pairs inside tokens and comments
    630662;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level
    631 ;; - Think about a good naming convention to distinguish parsers that accept
    632 ;;    one argument (an already-tokenized string) or multiple (raw header data)
Note: See TracChangeset for help on using the changeset viewer.