Message.Encoder and a few other bits

lib/content.ml

@@ -137,9 +137,9 @@ struct
     | `Skip line -> string line $ w_crlf
 
   let w_message { ty; encoding; version; id; description; content; _ } =
-    w_field (`ContentType ty)
+      w_field_version (`MimeVersion version)
+    $ w_field (`ContentType ty)
     $ w_field (`ContentEncoding encoding)
-    $ w_field_version (`MimeVersion version)
     $ (match id          with Some v -> w_field (`ContentID v) | None -> noop)
     $ (match description with Some v -> w_field (`ContentDescription v) | None -> noop)
     $ (Map.fold (fun field values acc -> List.fold_right (fun value -> w_field (`Content (field, value))) values $ acc) content noop)

lib/header.ml

@@ -285,21 +285,21 @@ struct
   let w_header { date; from; sender; reply_to; to'; cc; bcc; subject;
                  msg_id; in_reply_to; references; comments; keywords;
                  resents; traces; fields; unsafe; _ } =
-    (match date        with Some v -> w_field (`Date v) | None -> noop)
+      List.fold_right Trace.Encoder.w_trace traces
+    $ (match date        with Some v -> w_field (`Date v) | None -> noop)
     $ (match from        with [] -> noop | v -> w_field (`From v))
     $ (match sender      with Some v -> w_field (`Sender v) | None -> noop)
     $ (match reply_to    with [] -> noop | v -> w_field (`ReplyTo v))
     $ (match to'         with [] -> noop | v -> w_field (`To v))
     $ (match cc          with [] -> noop | v -> w_field (`Cc v))
     $ (match bcc         with [] -> noop | v -> w_field (`Bcc v))
-    $ (match subject     with Some v -> w_field (`Subject v) | None -> noop)
     $ (match msg_id      with Some v -> w_field (`MessageID v) | None -> noop)
+    $ (match subject     with Some v -> w_field (`Subject v) | None -> noop)
     $ (match in_reply_to with [] -> noop | v -> w_field (`InReplyTo v))
     $ (match references  with [] -> noop | v -> w_field (`References v))
     $ List.fold_right (fun v -> w_field (`Comments v)) comments
     $ List.fold_right (fun v -> w_field (`Keywords v)) keywords
     $ List.fold_right Resent.Encoder.w_resent resents
-    $ List.fold_right Trace.Encoder.w_trace traces
     $ (Map.fold (fun field values acc -> List.fold_right (fun value -> w_field (`Field (field, value))) values $ acc) fields noop)
     $ (Map.fold (fun field values acc -> List.fold_right (fun value -> w_field (`Unsafe (field, value))) values $ acc) unsafe noop)
 end

lib/message.ml

@@ -233,45 +233,66 @@ struct
         Content.Encoder.w_part content
         $ w_crlf
         $ w_body content body
+        $ string (Rfc2046.make_close_delimiter boundary)
       | [ (content, _fields, Some (Top.PMultipart lst)) ] ->
         Content.Encoder.w_part content
         $ w_crlf
         $ w_multipart content lst
+        $ string (Rfc2046.make_close_delimiter boundary)
       | [ (content, _fields, None) ] ->
         Content.Encoder.w_part content
         $ w_crlf
+        $ string (Rfc2046.make_close_delimiter boundary)
+      | [content, _fields, Some (Top.PMessage (headers, message))] ->
+        Content.Encoder.w_part content
+        $ w_crlf
+        $ _w_message (headers, message)
+        $ string (Rfc2046.make_close_delimiter boundary)
+      | (content, _fields, Some (Top.PMessage (headers, message))) :: r ->
+        Content.Encoder.w_part content
+        $ w_crlf
+        $ _w_message (headers, message)
+        $ w_crlf
+        $ string (Rfc2046.make_delimiter boundary)
+        $ w_crlf
+        $ aux r
       | (content, _fields, Some (Top.PDiscrete body)) :: r ->
         Content.Encoder.w_part content
         $ w_crlf
         $ w_body content body
         $ string (Rfc2046.make_delimiter boundary)
+        $ w_crlf
         $ aux r
       | (content, _fields, Some (Top.PMultipart lst)) :: r ->
         Content.Encoder.w_part content
         $ w_crlf
         $ w_multipart content lst
         $ string (Rfc2046.make_delimiter boundary)
+        $ w_crlf
         $ aux r
       | (content, _fields, None) :: r ->
         Content.Encoder.w_part content
         $ w_crlf
         $ string (Rfc2046.make_delimiter boundary)
+        $ w_crlf
         $ aux r
-      | _ -> assert false (* impossible to have an empty list *)
-                          (* other case, TODO! *)
+      | _::_ -> assert false (* other case, TODO! *)
+      | [] -> assert false (* impossible to have an empty list *)
     in
     string (Rfc2046.make_delimiter boundary)
     $ w_crlf
     $ aux lst
 
-  let _w_message (_header, body) =
+  and _w_message (header, body) =
     match body with
     | Top.Multipart (content, _fields, lst) ->
-      Content.Encoder.w_message content
+        Header.Encoder.w_header header
+      $ Content.Encoder.w_message content
       $ w_crlf
       $ w_multipart content lst
     | Top.Discrete (content, _fields, body) ->
-      Content.Encoder.w_message content
+        Header.Encoder.w_header header
+      $ Content.Encoder.w_message content
       $ w_crlf
       $ w_body content body
     | _ -> assert false (* TODO: not implemented yet *)

lib/message.mli

@@ -32,6 +32,36 @@ sig
   val p_end_of_part      : Content.t -> [ `End | `Next ] Parser.t
 end
 
+module Encoder :
+sig
+  val w_encode :
+    string ->
+    (Encoder.t ->
+     ([> `Partial of bytes * int * int * (int -> 'a) ] as 'a)) ->
+    Encoder.t -> 'a
+  val w_body :
+    Content.t ->
+    encoding ->
+    ([> `Partial of bytes * int * int * (int -> 'a) ] as 'a)
+    Encoder.k0
+  val w_crlf :
+    (Encoder.t ->
+     ([> `Partial of bytes * int * int * (int -> 'a) ] as 'a)) ->
+    Encoder.t -> 'a
+  exception Expected_boundary
+  val w_multipart :
+    Content.t ->
+    (Content.t * field_part list * (encoding, 'a) part option) list ->
+    (Encoder.t ->
+     ([> `Partial of bytes * int * int * (int -> 'b) ] as 'b)) ->
+    Encoder.t -> 'b
+  val _w_message :
+    Header.header * (encoding, 'b) message ->
+    (Encoder.t ->
+     ([> `Partial of bytes * int * int * (int -> 'c) ] as 'c)) ->
+    Encoder.t -> 'c
+end
+
 module Extension :
 sig
   val add_encoding : string -> (unit Parser.t -> unit Parser.t -> encoding Parser.t) -> unit

lib/trace.ml

@@ -83,11 +83,13 @@ struct
       $ (fun k -> Wrap.(lift ((hovbox 0 $ w_lst space w_data l $ close_box) (unlift k))))
       $ w_crlf
     | `ReturnPath (Some m) ->
-      string  "Return-Path: "
+      (* XXX Should probably be a version in Address.Encoder which writes <mailbox> *)
+      string  "Return-Path: <"
       $ (fun k -> Wrap.(lift ((hovbox 0 $ Address.Encoder.w_mailbox' m $ close_box) (unlift k))))
+      $ string ">"
       $ w_crlf
     | `ReturnPath None ->
-      string "Return-Path: < >" $ w_crlf
+      string "Return-Path: <>" $ w_crlf
 
   let w_field = function
     | `Trace (Some trace, received) ->