diff --git a/collects/net/mime-util.rkt b/collects/net/mime-util.rkt index 7489d3ee6e..fff30fcfe0 100644 --- a/collects/net/mime-util.rkt +++ b/collects/net/mime-util.rkt @@ -101,13 +101,8 @@ (define lowercase string-downcase) (define warning - void - #; (lambda (msg . args) - (fprintf (current-error-port) - (apply format (cons msg args))) - (newline (current-error-port))) - ) + (log-warning (apply format (cons msg args))))) ;; Copies its input `in' to its ouput port if given, it uses ;; current-output-port if out is not provided. diff --git a/collects/net/mime.rkt b/collects/net/mime.rkt index 508a656597..938a067638 100644 --- a/collects/net/mime.rkt +++ b/collects/net/mime.rkt @@ -34,7 +34,7 @@ ;; -- exceptions raised -- (struct-out mime-error) (struct-out unexpected-termination) - (struct-out missing-multipart-boundary-parameter) + (struct-out missing-multipart-boundary-parameter) ; this is the only one actually raised (struct-out malformed-multipart-entity) (struct-out empty-mechanism) (struct-out empty-type) @@ -77,6 +77,9 @@ ("base64" . base64))) (define ietf-extensions '()) + +;; We don't try to keep up with IANA substypes +#; (define iana-extensions '(;; text ("plain" . plain) @@ -140,9 +143,10 @@ #:mutable) ;; Exceptions -(define-struct mime-error ()) +(define-struct (mime-error exn:fail) ()) (define-struct (unexpected-termination mime-error) (msg)) (define-struct (missing-multipart-boundary-parameter mime-error) ()) + (define-struct (malformed-multipart-entity mime-error) (msg)) (define-struct (empty-mechanism mime-error) ()) (define-struct (empty-type mime-error) ()) @@ -238,7 +242,9 @@ (let ([boundary (entity-boundary entity)]) (when (not boundary) (when (eq? 'multipart (entity-type entity)) - (raise (make-missing-multipart-boundary-parameter)))) + (raise (make-missing-multipart-boundary-parameter + "missing multipart \"boundary\" parameter" + (current-continuation-marks))))) (set-entity-parts! entity (map (lambda (part) (mime-analyze part #t)) @@ -615,9 +621,10 @@ ;; iana-token := +;; Instead of trying to list all registered types +;; here, we just convert to a symbol. (define (iana-token value) - (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) - (and ans (cdr ans)))) + (string->symbol (lowercase (trim-spaces value)))) ;; parameter := attribute "=" value (define re:parameter (regexp "([^=]+)=(.+)")) diff --git a/collects/net/scribblings/mime.scrbl b/collects/net/scribblings/mime.scrbl index f611e1e641..a68b66370c 100644 --- a/collects/net/scribblings/mime.scrbl +++ b/collects/net/scribblings/mime.scrbl @@ -36,11 +36,16 @@ The library was written by Francisco Solsona.} @section{Message Decoding} @defproc[(mime-analyze [message-in (or/c bytes? input-port)] - [part? any/c]) + [part? any/c #f]) message?]{ Parses @racket[message-in] and returns the parsed result as a -@racket[message] instance.} +@racket[message] instance. + +If @racket[part?] is @racket[#f], then @racket[message-in] should +start with the header for a full message; otherwise, +@racket[message-in] should start with the header for a part within a +message.} @defstruct[message ([version real?] [entity entity] @@ -61,16 +66,20 @@ field contains one string for each field in the message header.} [other (listof string?)] [fields (listof string?)] [parts (listof message?)] - [body (output-port? . -> . void?)])]{ + [body (or/c (output-port? . -> . void?) null?)])]{ -Represents the content of a message or a sub-part. +Represents the content of a message or a sub-part. The +@racket[mime-analyze] function chooses default values for fields +when they are not specified in input. Standard values for the @racket[type] field include @racket['text], @racket['image], @racket['audio], @racket['video], @racket['application], @racket['message], and @racket['multipart]. Standard values for the @racket[subtype] field depend on the -@racket[type] field, and include the following: +@racket[type] field, and include the following, but any +@racket[subtype] is allowed as a downcased version of the +specification from the header. @mime-table[ ( @@ -150,11 +159,11 @@ messages. This list is non-empty only when @racket[type] is @racket['multipart] or @racket['message]. The @racket[body] field represents the body as a function that -consumes an output out and writes the decoded message to the port. No -bytes are written if @racket[type] is @racket['multipart] or -@racket['message]. All of the standard values of @racket[encoding] -are supported. The procedure only works once (since the encoded body -is pulled from a stream).} +consumes an output out and writes the decoded message to the port. If +@racket[type] is @racket['multipart] or @racket['message]., then +@racket[body] is @racket['()]. All of the standard values of +@racket[encoding] are supported. The procedure only works once (since +the encoded body is pulled from a stream).} @defstruct[disposition ([type symbol?] [filename (or/c string? false/c)] @@ -189,48 +198,43 @@ the @racket["Content-Disposition"] header, if included in the message.} @section[#:tag "mime-exns"]{Exceptions} -@defstruct[mime-error ()]{ +@defstruct[(mime-error exn:fail) ()]{ -The supertype of all MIME exceptions.} +The supertype of all MIME exceptions. Only the subtype +@racket[missing-multipart-boundary-parameter] is ever actually +raised.} @defstruct[(unexpected-termination mime-error) ([msg string?])]{ -Raised when an end-of-file is reached while parsing the headers of a -MIME entity. It usually means that the message does not conform -to RFC 2045 and friends.} +Originally raised when an end-of-file is reached while parsing the +headers of a MIME entity, but currently a mere warning is logged.} @defstruct[(missing-multipart-boundary-parameter mime-error) ()]{ Raised when a multipart type is specified, but no @racket["Boundary"] -parameter is given or an end-of-file is encountered before the -boundary.} +parameter is given.} @defstruct[(malformed-multipart-entity mime-error) ([msg string?])]{ -Similar to @racket[unexpected-termination], but used only while -scanning parts of a multipart message.} +Never actually raised.} @defstruct[(empty-mechanism mime-error) ()]{ -Raised when no transport encoding mechanism was provided with the -@racket["Content-Transfer-Encoding"] field.} +Never actually raised.} @defstruct[(empty-type mime-error) ()]{ -Raised when no type is specified for @racket["Content-Type"], or when -the specification is incorrectly formatted.} +Never actually raised.} @defstruct[(empty-subtype mime-error) ()]{ -Raised when no sub-type is specified for @racket["Content-Type"], or -when the specification is incorrectly formatted.} +Never actually raised.} @defstruct[(empty-disposition-type mime-error) ()]{ -Raised when type specified for the @racket["Content-Disposition"] -field, or when the specification is incorrectly formatted.} +Never actually raised.} @; ---------------------------------------- diff --git a/collects/tests/net/mime.rkt b/collects/tests/net/mime.rkt new file mode 100644 index 0000000000..5ec1dbaf33 --- /dev/null +++ b/collects/tests/net/mime.rkt @@ -0,0 +1,65 @@ +#lang racket/base +(require net/mime) + +(define-syntax-rule (test expect expr) + (let ([val expr]) + (unless (equal? expect val) + (error 'test "failed at ~s: ~e" 'expr val)))) + +;; This test is based on an example from Jordan Schatz + +(define ip + (open-input-string + (regexp-replace* #rx"(\r\n|\n)" +#<; rel="up" +Etag: 1qS8Wrr2vkTBxkITOjo33K +Last-Modified: Wed, 04 Jan 2012 17:12:32 GMT + +{"date": "11/02/2011"} +--NdzDrpIQMsJKtfv9VrXmp4YwCPh-- + +--9nbsYRvJBLRyuL4VOuuejw9LcAy-- +EOS +"\r\n"))) + +(let* ([analyzed (mime-analyze ip)] + [our-entity (message-entity analyzed)] + [parts (entity-parts our-entity)] + [inner-message (car parts)] + [inner-entity (message-entity inner-message)] + [body-proc (entity-body inner-entity)] + [tmp (open-output-string)]) + (test '("Server: MochiWeb/1.1 WebMachine/1.9.0 (someone had painted it blue)" + "Expires: Fri, 06 Jan 2012 02:01:12 GMT" + "Date: Fri, 06 Jan 2012 01:51:12 GMT") + (message-fields analyzed)) + (test 1 (length parts)) + (test '() body-proc) + (test 1 (length (entity-parts inner-entity))) + (define sub (message-entity (car (entity-parts inner-entity)))) + (test 'application (entity-type sub)) + (test 'json (entity-subtype sub)) + ((entity-body sub) tmp) + (test "{\"date\": \"11/02/2011\"}" (get-output-string tmp))) + +(test 'not-there (with-handlers ([exn:fail? + (lambda (exn) + (and (missing-multipart-boundary-parameter? exn) + 'not-there))]) + (mime-analyze + (open-input-string "Content-Type: multipart/mixed\r\n\r\n"))))