net/mime: allow any subtype, exns as exn:fail subtypes; doc fixes

original commit: 7153fbd4d5

collects/net/mime-util.rkt

@@ -101,13 +101,8 @@
 (define lowercase string-downcase)
 
 (define warning
-  void
-  #;
   (lambda (msg . args)
-    (fprintf (current-error-port)
+    (log-warning (apply format (cons msg args)))))
-             (apply format (cons msg args)))
-    (newline (current-error-port)))
-  )
 
 ;; Copies its input `in' to its ouput port if given, it uses
 ;; current-output-port if out is not provided.

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 := <A publicly-defined extension token. Tokens
 ;;               of this form must be registered with IANA
 ;;               as specified in RFC 2048.>
+;;              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)])
+  (string->symbol (lowercase (trim-spaces value))))
-    (and ans (cdr ans))))
 
 ;; parameter := attribute "=" value
 (define re:parameter (regexp "([^=]+)=(.+)"))

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
+consumes an output out and writes the decoded message to the port. If
-bytes are written if @racket[type] is @racket['multipart] or
+@racket[type] is @racket['multipart] or @racket['message]., then
-@racket['message].  All of the standard values of @racket[encoding]
+@racket[body] is @racket['()]. All of the standard values of
-are supported. The procedure only works once (since the encoded body
+@racket[encoding] are supported. The procedure only works once (since
-is pulled from a stream).}
+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
+Originally raised when an end-of-file is reached while parsing the
-MIME entity.  It usually means that the message does not conform
+headers of a MIME entity, but currently a mere warning is logged.}
-to RFC 2045 and friends.}
 
 @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
+parameter is given.}
-boundary.}
 
 @defstruct[(malformed-multipart-entity mime-error) ([msg string?])]{
 
-Similar to @racket[unexpected-termination], but used only while
+Never actually raised.}
-scanning parts of a multipart message.}
 
 @defstruct[(empty-mechanism mime-error) ()]{
 
-Raised when no transport encoding mechanism was provided with the
+Never actually raised.}
-@racket["Content-Transfer-Encoding"] field.}
 
 @defstruct[(empty-type mime-error) ()]{
 
-Raised when no type is specified for @racket["Content-Type"], or when
+Never actually raised.}
-the specification is incorrectly formatted.}
 
 
 @defstruct[(empty-subtype mime-error) ()]{
 
-Raised when no sub-type is specified for @racket["Content-Type"], or
+Never actually raised.}
-when the specification is incorrectly formatted.}
 
 
 @defstruct[(empty-disposition-type mime-error) ()]{
 
-Raised when type specified for the @racket["Content-Disposition"]
+Never actually raised.}
-field, or when the specification is incorrectly formatted.}
 
 @; ----------------------------------------
 

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)"
+#<<EOS
+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
+Content-Type: multipart/mixed; boundary=9nbsYRvJBLRyuL4VOuuejw9LcAy
+Content-Length: 817
+
+
+--9nbsYRvJBLRyuL4VOuuejw9LcAy
+Content-Type: multipart/mixed; boundary=NdzDrpIQMsJKtfv9VrXmp4YwCPh
+
+--NdzDrpIQMsJKtfv9VrXmp4YwCPh
+X-Riak-Vclock: a85hYGBgzGDKBVIcypz/fvp9087NYEpkzGNlaGCpPMGXBQA=
+Location: /buckets/invoices/keys/RAQpCw8SssXlXVhiGAGYXsVmwvk
+Content-Type: application/json
+Link: </buckets/invoices>; 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"))))