Changeset 26946 in project


Ignore:
Timestamp:
06/22/12 19:58:30 (9 years ago)
Author:
sjamaan
Message:

intarweb: Add content-disposition header parser and refine unparser to support additional date/size parameters (initial patch and motivation by Evan Hanson)

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

Legend:

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

    r26780 r26946  
    239239  (disjoin rfc1123-string->time rfc850-string->time asctime-string->time))
    240240
     241;; RFC 1123 updates RFC 822's datetime spec
    241242(define (rfc1123-subparser str)
    242243  (or (rfc1123-string->time str)
     
    313314                 (total (string->number (irregex-match-substring m 'total))))
    314315        (list start end total)))))
     316
     317;; Accept *just* a filename, not a full path (simply strips directories)
     318;; This matches the content-disposition recommendation in RFC2616, 19.5.1:
     319;; "The receiving user agent SHOULD NOT respect any directory path
     320;;  information present in the filename-parm parameter, which is the only
     321;;  parameter believed to apply to HTTP implementations at this time. The
     322;;  filename SHOULD be treated as a terminal component only."
     323;; This echoes RFC2183 (and RFC1806 which it supersedes), section 2.3:
     324;; "The receiving MUA SHOULD NOT respect any directory path information
     325;;  that may seem to be present in the filename parameter.  The filename
     326;;  should be treated as a terminal component only."
     327(define (filename-subparser fn)
     328  (let ((base-fn (pathname-strip-directory (string-trim-both fn))))
     329    (and (not (member base-fn '("" "." "..")))
     330         (not (string-index base-fn (char-set #\/ #\nul)))
     331         base-fn)))
    315332
    316333;; [W/]<string>
     
    345362                    (value (and etag (vector (cons (if weak 'weak 'strong)
    346363                                                   etag) '()))))
    347                (if value
    348                    (if newpos
    349                        (loop newpos (cons value etags))
    350                        (reverse! (cons value etags)))
    351                    (reverse! etags)))))))))
     364                (if value
     365                    (if newpos
     366                        (loop newpos (cons value etags))
     367                        (reverse! (cons value etags)))
     368                    (reverse! etags)))))))))
    352369
    353370;; ( <product>[/<version>] [<comment>] )+
     
    398415(define old-style-cookie?
    399416  (let ((old-cookie-regex
    400          (irregex '(seq bos (+ (~ #\= #\")) "=" (* (~ #\;)) ";"
     417         (irregex '(seq bos (+ (~ #\= #\")) "=" (* (~ #\;)) ";" ;
    401418                        (* any) (w/nocase "expires") (* space) "="))))
    402419   (lambda (cookie)
     
    640657;; It's a bit annoying that our API currently can't specify for particular
    641658;; attributes that only those must be unparsed specially, so we quote _all_
    642 ;; attributes (which, strictly speaking, is always allowed for tokens).
     659;; attributes (which, strictly speaking, is always allowed for tokens) unless
     660;; otherwise specified by a hack (when the value is prefixed by RAW).
    643661;; This may be dangerous or wrong, if a server doesn't accept quoted "name"
    644662;; attributes, for example.  Not too likely since names can contain spaces etc.
    645663(define (content-disposition-unparser header-contents)
    646664  (let* ((type (get-value (car header-contents)))
    647          (unparser (lambda (x) (quote-string (->string x)))))
     665         (RAW (list 'raw))
     666         (unparser (lambda (x) (if (and (pair? x) (eq? RAW (car x)))
     667                                   (cdr x)
     668                                   (quote-string (->string x))))))
    648669    (list (conc (unparse-token type)
    649                 (unparse-params (get-params (car header-contents)) '()
     670                (unparse-params (get-params (car header-contents))
     671                                `((size . ,(lambda (x) (cons RAW (number->string x))))
     672                                  (creation-date . ,rfc1123-time->string)
     673                                  (modification-date . ,rfc1123-time->string)
     674                                  (read-date . ,rfc1123-time->string))
    650675                                value-unparser: unparser)))))
    651676
     
    750775
    751776(define (rfc1123-unparser header-contents)
    752   (list
    753    (let-locale ((LC_TIME "POSIX"))
    754                (time->string (get-value (car header-contents))
    755                              "%a, %d %b %Y %X GMT"))))
    756 
     777  (list (rfc1123-time->string (get-value (car header-contents)))))
     778
     779(define (rfc1123-time->string str)
     780  (let-locale ((LC_TIME "POSIX"))
     781    (time->string str "%a, %d %b %Y %X GMT")))
    757782
    758783(define (basic-auth-param-subunparser params)
  • release/4/intarweb/trunk/intarweb.scm

    r26864 r26946  
    7474   rfc1123-subparser rfc850-subparser  asctime-subparser http-date-subparser
    7575   quality-subparser unknown-header-parser
    76    symbol-subparser symbol-subparser-ci natnum-subparser
    77    host/port-subparser base64-subparser range-subparser
     76   filename-subparser symbol-subparser symbol-subparser-ci natnum-subparser
     77   host/port-subparser base64-subparser range-subparser filename-subparser
    7878   etag-parser product-parser mailbox-subparser if-range-parser
    7979   retry-after-subparser via-parser warning-parser key/value-subparser
     
    9696 
    9797  (use extras ports data-structures srfi-1 srfi-13 srfi-14 irregex posix
    98        base64 defstruct uri-common)
     98       base64 defstruct uri-common files)
    9999
    100100(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
     
    371371     (warning . ,warning-parser)
    372372     (www-authenticate . ,authenticate-parser)
     373     ;; RFC 2183
     374     (content-disposition . ,(single symbol-subparser-ci
     375                                     `((filename . ,filename-subparser)
     376                                       (creation-date . ,rfc1123-subparser)
     377                                       (modification-date . ,rfc1123-subparser)
     378                                       (read-date . ,rfc1123-subparser)
     379                                       (size . ,natnum-subparser))))
    373380     ;; RFC 2109
    374381     (set-cookie . ,set-cookie-parser)
  • release/4/intarweb/trunk/tests/run.scm

    r26187 r26946  
    293293            '(500 999 1234)
    294294            (header-value 'content-range headers))))
     295
     296  (test-group "Content-disposition"
     297    (let ((headers (test-read-headers "Content-Disposition: attachment; filename=dir/foo.jpg")))
     298      (test "Attachment with filename parameter containing directory"
     299            `(attachment (filename . "foo.jpg"))
     300            (cons (header-value  'content-disposition headers)
     301                  (header-params 'content-disposition headers))))
     302    (let ((headers (test-read-headers "Content-Disposition: inline; filename=foo.jpg; creation-date=Sun, 06 Nov 1994 08:49:37 GMT")))
     303      (test "Inline with filename and (not quoted) creation-date parameter"
     304            `(inline
     305              (filename . "foo.jpg")
     306              (creation-date . ,(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0))))
     307            (cons (header-value  'content-disposition headers)
     308                  (map (lambda (x)
     309                         (if (vector? (cdr x))
     310                             (cons (car x) (utc-time->seconds (cdr x)))
     311                             x))
     312                       (header-params 'content-disposition headers)))))
     313    (let ((headers (test-read-headers "Content-Disposition: inline; read-date=\"Sun, 06 Nov 1994 08:49:37 GMT\"; size=100")))
     314      (test "Inline with size and (quoted) read-date parameter"
     315            `(inline
     316              (read-date . ,(utc-time->seconds '#(37 49 08 06 10 94 0 310 #f 0)))
     317              (size . 100))
     318            (cons (header-value  'content-disposition headers)
     319                  (map (lambda (x)
     320                         (if (vector? (cdr x))
     321                             (cons (car x) (utc-time->seconds (cdr x)))
     322                             x))
     323                       (header-params 'content-disposition headers))))))
    295324
    296325  (test-group "normalized-uri"
     
    724753          (test-unparse-headers `((content-disposition
    725754                                   #(form-data ((name . "foo")
    726                                                 (filename . "a b c")))))))))
     755                                                (filename . "a b c")))))))
     756    (test "Size and dates are recognised correctly"
     757          "Content-Disposition: inline; size=20; creation-date=\"Sun, 06 Nov 1994 08:49:37 GMT\"\r\n"
     758          (test-unparse-headers `((content-disposition
     759                                   #(inline ((size . 20)
     760                                             (creation-date . #(37 49 08 06 10 94 0 310 #f 0))))))))))
    727761
    728762(define (test-read-request str)
Note: See TracChangeset for help on using the changeset viewer.