My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** Email body part and body value implementation.
2
3 This module implements email body part types and operations as specified in
4 RFC 8621 Section 4.1.4. It provides MIME structure handling, content access,
5 and validation for email body parts and decoded content values.
6
7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.4> RFC 8621, Section 4.1.4
8*)
9
10type t = {
11 id : string option;
12 blob_id : Jmap.Id.t option;
13 size : Jmap.UInt.t;
14 headers : Header.t list;
15 name : string option;
16 mime_type : string;
17 charset : string option;
18 disposition : string option;
19 disposition_params : (string, string) Hashtbl.t option;
20 cid : string option;
21 language : string list option;
22 location : string option;
23 sub_parts : t list option;
24 boundary : string option;
25 content_transfer_encoding : string option;
26 other_headers : (string, Yojson.Safe.t) Hashtbl.t;
27}
28
29let id t = t.id
30let blob_id t = t.blob_id
31let size t = t.size
32let headers t = t.headers
33let name t = t.name
34let mime_type t = t.mime_type
35let charset t = t.charset
36let disposition t = t.disposition
37let disposition_params t = t.disposition_params
38let cid t = t.cid
39let language t = t.language
40let location t = t.location
41let sub_parts t = t.sub_parts
42let boundary t = t.boundary
43let content_transfer_encoding t = t.content_transfer_encoding
44let other_headers t = t.other_headers
45
46(** MIME parameter parsing utilities *)
47module MIME_params = struct
48 (** Parse MIME parameters from a header value like "text/html; charset=utf-8; boundary=foo" *)
49 let parse_parameters (value : string) : (string * string) list =
50 let parts = Str.split (Str.regexp ";") value in
51 match parts with
52 | [] -> []
53 | _main_type :: param_parts ->
54 List.filter_map (fun part ->
55 let trimmed = String.trim part in
56 if String.contains trimmed '=' then
57 let equals_pos = String.index trimmed '=' in
58 let name = String.trim (String.sub trimmed 0 equals_pos) in
59 let value_part = String.trim (String.sub trimmed (equals_pos + 1) (String.length trimmed - equals_pos - 1)) in
60 (* Remove quotes if present *)
61 let clean_value =
62 if String.length value_part >= 2 && value_part.[0] = '"' && value_part.[String.length value_part - 1] = '"' then
63 String.sub value_part 1 (String.length value_part - 2)
64 else value_part
65 in
66 Some (String.lowercase_ascii name, clean_value)
67 else None
68 ) param_parts
69
70 (** Get main MIME type from a Content-Type value *)
71 let get_main_type (content_type : string) : string =
72 let parts = Str.split (Str.regexp ";") content_type in
73 match parts with
74 | main :: _ -> String.trim (String.lowercase_ascii main)
75 | [] -> content_type
76
77 (** Find a specific parameter value *)
78 let find_param (params : (string * string) list) (name : string) : string option =
79 List.assoc_opt (String.lowercase_ascii name) params
80end
81
82(** Content-Transfer-Encoding handling utilities *)
83module Encoding = struct
84 (** Decode quoted-printable encoded content *)
85 let decode_quoted_printable (content : string) : (string, string) result =
86 try
87 let buffer = Buffer.create (String.length content) in
88 let len = String.length content in
89 let rec process i =
90 if i >= len then ()
91 else if content.[i] = '=' && i + 2 < len then
92 let hex_str = String.sub content (i + 1) 2 in
93 if hex_str = "\r\n" || hex_str = "\n" then
94 process (i + 3) (* Soft line break *)
95 else
96 try
97 let byte_val = int_of_string ("0x" ^ hex_str) in
98 Buffer.add_char buffer (char_of_int byte_val);
99 process (i + 3)
100 with _ ->
101 Buffer.add_char buffer content.[i];
102 process (i + 1)
103 else (
104 Buffer.add_char buffer content.[i];
105 process (i + 1)
106 )
107 in
108 process 0;
109 Ok (Buffer.contents buffer)
110 with exn ->
111 Error ("Quoted-printable decoding failed: " ^ Printexc.to_string exn)
112
113 (** Decode base64 encoded content *)
114 let decode_base64 (content : string) : (string, string) result =
115 try
116 (* Remove whitespace and newlines *)
117 let clean_content = Str.global_replace (Str.regexp "[\r\n\t ]+") "" content in
118 match Base64.decode clean_content with
119 | Ok decoded -> Ok decoded
120 | Error (`Msg msg) -> Error ("Base64 decoding failed: " ^ msg)
121 with exn ->
122 Error ("Base64 decoding failed: " ^ Printexc.to_string exn)
123
124 (** Decode content based on Content-Transfer-Encoding *)
125 let decode_content (encoding : string option) (content : string) : (string * bool) =
126 match encoding with
127 | Some enc when String.lowercase_ascii enc = "quoted-printable" ->
128 (match decode_quoted_printable content with
129 | Ok decoded -> (decoded, false)
130 | Error _ -> (content, true)) (* Keep original on error, mark encoding problem *)
131 | Some enc when String.lowercase_ascii enc = "base64" ->
132 (match decode_base64 content with
133 | Ok decoded -> (decoded, false)
134 | Error _ -> (content, true)) (* Keep original on error, mark encoding problem *)
135 | Some "7bit" | Some "8bit" | Some "binary" | None ->
136 (content, false) (* No decoding needed *)
137 | Some _unknown ->
138 (content, true) (* Unknown encoding, mark as problem *)
139end
140
141let validate_mime_type mime_type =
142 if mime_type = "" then
143 Error "MIME type cannot be empty"
144 else if not (String.contains mime_type '/') then
145 Error "MIME type must contain a '/' separator"
146 else
147 Ok ()
148
149let validate_body_part ~id ~blob_id ~sub_parts ~mime_type =
150 match validate_mime_type mime_type with
151 | Error msg -> Error msg
152 | Ok () ->
153 let is_multipart = String.length mime_type >= 9 &&
154 String.sub mime_type 0 9 = "multipart" in
155 match is_multipart, sub_parts, id, blob_id with
156 | true, Some _, None, None -> Ok () (* Multipart with sub-parts *)
157 | true, Some _, _, _ -> Error "Multipart body parts cannot have id or blob_id"
158 | true, None, _, _ -> Error "Multipart body parts must have sub_parts"
159 | false, None, _, _ -> Ok () (* Leaf part without sub-parts *)
160 | false, Some _, _, _ -> Error "Non-multipart body parts cannot have sub_parts"
161
162let create ?id ?blob_id ~size ~headers ?name ~mime_type ?charset
163 ?disposition ?disposition_params ?cid ?language ?location ?sub_parts
164 ?boundary ?content_transfer_encoding ?(other_headers = Hashtbl.create 0) () =
165 match validate_body_part ~id ~blob_id ~sub_parts ~mime_type with
166 | Ok () ->
167 Ok {
168 id; blob_id; size; headers; name; mime_type; charset;
169 disposition; disposition_params; cid; language; location; sub_parts; boundary;
170 content_transfer_encoding; other_headers
171 }
172 | Error msg -> Error msg
173
174let create_unsafe ?id ?blob_id ~size ~headers ?name ~mime_type ?charset
175 ?disposition ?disposition_params ?cid ?language ?location ?sub_parts
176 ?boundary ?content_transfer_encoding ?(other_headers = Hashtbl.create 0) () =
177 {
178 id; blob_id; size; headers; name; mime_type; charset;
179 disposition; disposition_params; cid; language; location; sub_parts; boundary;
180 content_transfer_encoding; other_headers
181 }
182
183let is_multipart t =
184 String.length t.mime_type >= 9 && String.sub t.mime_type 0 9 = "multipart"
185
186let is_leaf t = not (is_multipart t)
187
188let is_attachment t =
189 match t.disposition with
190 | Some disp -> String.lowercase_ascii (String.trim disp) = "attachment"
191 | None ->
192 (* Use MIME type heuristics as per RFC 8621 *)
193 let lower_type = String.lowercase_ascii t.mime_type in
194 let is_inline_type =
195 lower_type = "text/plain" || lower_type = "text/html" ||
196 (String.length lower_type >= 6 && String.sub lower_type 0 6 = "image/") ||
197 (String.length lower_type >= 6 && String.sub lower_type 0 6 = "audio/") ||
198 (String.length lower_type >= 6 && String.sub lower_type 0 6 = "video/")
199 in
200 not is_inline_type
201
202let is_inline t =
203 match t.disposition with
204 | Some disp -> String.lowercase_ascii (String.trim disp) = "inline"
205 | None -> not (is_attachment t)
206
207let rec get_leaf_parts t =
208 match t.sub_parts with
209 | None -> [t] (* This is a leaf part *)
210 | Some parts -> List.concat_map get_leaf_parts parts
211
212let match_mime_type pattern mime_type =
213 if pattern = mime_type then true
214 else if String.contains pattern '*' then
215 let pattern_prefix = String.sub pattern 0 (String.index pattern '*') in
216 String.length mime_type >= String.length pattern_prefix &&
217 String.sub mime_type 0 (String.length pattern_prefix) = pattern_prefix
218 else false
219
220let rec find_by_mime_type t pattern =
221 let current_matches = if match_mime_type pattern t.mime_type then [t] else [] in
222 let sub_matches = match t.sub_parts with
223 | None -> []
224 | Some parts -> List.concat_map (fun p -> find_by_mime_type p pattern) parts
225 in
226 current_matches @ sub_matches
227
228(** Generate a unique part ID for a body part at given depth and position *)
229let generate_part_id (depth : int) (position : int) : string =
230 if depth = 0 then string_of_int position
231 else Printf.sprintf "%d.%d" depth position
232
233(** Validate part ID format *)
234let is_valid_part_id (part_id : string) : bool =
235 let id_re = Str.regexp "^[0-9]+\\(\\.[0-9]+\\)*$" in
236 Str.string_match id_re part_id 0
237
238(** Extract MIME parameters from Content-Type header *)
239let extract_mime_params (headers : Header.t list) : string option * (string * string) list =
240 match Header.find_by_name headers "content-type" with
241 | Some header ->
242 let content_type_value = Header.value header in
243 let params = MIME_params.parse_parameters content_type_value in
244 (Some content_type_value, params)
245 | None -> (None, [])
246
247(** Extract Content-Disposition parameters *)
248let extract_disposition_params (headers : Header.t list) : string option * (string * string) list =
249 match Header.find_by_name headers "content-disposition" with
250 | Some header ->
251 let disposition_value = Header.value header in
252 let params = MIME_params.parse_parameters disposition_value in
253 (Some (MIME_params.get_main_type disposition_value), params)
254 | None -> (None, [])
255
256(** Body structure flattening for textBody/htmlBody/attachments as per RFC 8621 algorithm *)
257module Flattener = struct
258 type flattened_parts = {
259 text_body : t list;
260 html_body : t list;
261 attachments : t list;
262 }
263
264 let empty_parts = { text_body = []; html_body = []; attachments = [] }
265
266 let is_inline_media_type mime_type =
267 let lower = String.lowercase_ascii mime_type in
268 String.length lower >= 6 && (
269 String.sub lower 0 6 = "image/" ||
270 String.sub lower 0 6 = "audio/" ||
271 String.sub lower 0 6 = "video/"
272 )
273
274 let rec flatten_structure (parts : t list) (multipart_type : string)
275 (in_alternative : bool) (acc : flattened_parts) : flattened_parts =
276 List.fold_left (fun acc part ->
277 let is_inline_part = is_inline part in
278 if is_multipart part then
279 match part.sub_parts with
280 | Some sub_parts ->
281 let sub_multipart_type =
282 let mime_parts = String.split_on_char '/' part.mime_type in
283 match mime_parts with
284 | ["multipart"; subtype] -> subtype
285 | _ -> "mixed"
286 in
287 flatten_structure sub_parts sub_multipart_type
288 (in_alternative || sub_multipart_type = "alternative") acc
289 | None -> acc
290 else if is_inline_part then
291 if multipart_type = "alternative" then
292 match String.lowercase_ascii part.mime_type with
293 | "text/plain" ->
294 { acc with text_body = part :: acc.text_body }
295 | "text/html" ->
296 { acc with html_body = part :: acc.html_body }
297 | _ ->
298 { acc with attachments = part :: acc.attachments }
299 else if in_alternative then
300 let new_acc = { acc with text_body = part :: acc.text_body;
301 html_body = part :: acc.html_body } in
302 if is_inline_media_type part.mime_type then
303 { new_acc with attachments = part :: new_acc.attachments }
304 else new_acc
305 else
306 let new_acc = { acc with text_body = part :: acc.text_body;
307 html_body = part :: acc.html_body } in
308 if is_inline_media_type part.mime_type then
309 { new_acc with attachments = part :: new_acc.attachments }
310 else new_acc
311 else
312 { acc with attachments = part :: acc.attachments }
313 ) acc parts
314
315 (** Flatten body structure into textBody, htmlBody, and attachments lists *)
316 let flatten (body_structure : t) : flattened_parts =
317 let result = flatten_structure [body_structure] "mixed" false empty_parts in
318 { text_body = List.rev result.text_body;
319 html_body = List.rev result.html_body;
320 attachments = List.rev result.attachments }
321end
322
323(** Get text body parts (for textBody property) *)
324let get_text_body (t : t) : t list =
325 let flattened = Flattener.flatten t in
326 flattened.text_body
327
328(** Get HTML body parts (for htmlBody property) *)
329let get_html_body (t : t) : t list =
330 let flattened = Flattener.flatten t in
331 flattened.html_body
332
333(** Get attachment parts (for attachments property) *)
334let get_attachments (t : t) : t list =
335 let flattened = Flattener.flatten t in
336 flattened.attachments
337
338
339let rec to_json t =
340 let fields = [
341 ("size", `Int (Jmap.UInt.to_int t.size));
342 ("headers", Header.list_to_json t.headers);
343 ("type", `String t.mime_type);
344 ] in
345 let add_opt_string fields name = function
346 | Some s -> (name, `String s) :: fields
347 | None -> fields
348 in
349 let add_opt_string_list fields name = function
350 | Some lst -> (name, `List (List.map (fun s -> `String s) lst)) :: fields
351 | None -> fields
352 in
353 let add_opt_hashtbl fields name = function
354 | Some tbl when Hashtbl.length tbl > 0 ->
355 let params = Hashtbl.fold (fun k v acc -> (k, `String v) :: acc) tbl [] in
356 (name, `Assoc params) :: fields
357 | _ -> fields
358 in
359 let fields = add_opt_string fields "partId" t.id in
360 let fields = add_opt_string fields "blobId" (Option.map Jmap.Id.to_string t.blob_id) in
361 let fields = add_opt_string fields "name" t.name in
362 let fields = add_opt_string fields "charset" t.charset in
363 let fields = add_opt_string fields "disposition" t.disposition in
364 let fields = add_opt_hashtbl fields "dispositionParams" t.disposition_params in
365 let fields = add_opt_string fields "cid" t.cid in
366 let fields = add_opt_string_list fields "language" t.language in
367 let fields = add_opt_string fields "location" t.location in
368 let fields = add_opt_string fields "boundary" t.boundary in
369 let fields = add_opt_string fields "contentTransferEncoding" t.content_transfer_encoding in
370 let fields = match t.sub_parts with
371 | Some parts -> ("subParts", `List (List.map to_json parts)) :: fields
372 | None -> fields
373 in
374 let fields = if Hashtbl.length t.other_headers > 0 then
375 let other_fields = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.other_headers [] in
376 other_fields @ fields
377 else fields
378 in
379 `Assoc fields
380
381let rec of_json = function
382 | `Assoc fields ->
383 (try
384 let size = match List.assoc_opt "size" fields with
385 | Some (`Int s) -> (match Jmap.UInt.of_int s with
386 | Ok uint -> uint
387 | Error _ -> failwith ("Invalid size: " ^ string_of_int s))
388 | _ -> failwith "Missing or invalid size field"
389 in
390 let headers = match List.assoc_opt "headers" fields with
391 | Some json ->
392 (match Header.list_of_json json with
393 | Ok h -> h
394 | Error msg -> failwith ("Invalid headers: " ^ msg))
395 | None -> []
396 in
397 let mime_type = match List.assoc_opt "type" fields with
398 | Some (`String t) -> t
399 | _ -> failwith "Missing or invalid type field"
400 in
401 let id = match List.assoc_opt "partId" fields with
402 | Some (`String s) -> Some s
403 | Some `Null | None -> None
404 | _ -> failwith "Invalid partId field"
405 in
406 let blob_id = match List.assoc_opt "blobId" fields with
407 | Some (`String s) -> (match Jmap.Id.of_string s with
408 | Ok id_t -> Some id_t
409 | Error _ -> failwith ("Invalid blob_id: " ^ s))
410 | Some `Null | None -> None
411 | _ -> failwith "Invalid blobId field"
412 in
413 let name = match List.assoc_opt "name" fields with
414 | Some (`String s) -> Some s
415 | Some `Null | None -> None
416 | _ -> failwith "Invalid name field"
417 in
418 let charset = match List.assoc_opt "charset" fields with
419 | Some (`String s) -> Some s
420 | Some `Null | None -> None
421 | _ -> failwith "Invalid charset field"
422 in
423 let disposition = match List.assoc_opt "disposition" fields with
424 | Some (`String s) -> Some s
425 | Some `Null | None -> None
426 | _ -> failwith "Invalid disposition field"
427 in
428 let cid = match List.assoc_opt "cid" fields with
429 | Some (`String s) -> Some s
430 | Some `Null | None -> None
431 | _ -> failwith "Invalid cid field"
432 in
433 let language = match List.assoc_opt "language" fields with
434 | Some (`List items) ->
435 Some (List.map (function
436 | `String s -> s
437 | _ -> failwith "Invalid language list item") items)
438 | Some `Null | None -> None
439 | _ -> failwith "Invalid language field"
440 in
441 let location = match List.assoc_opt "location" fields with
442 | Some (`String s) -> Some s
443 | Some `Null | None -> None
444 | _ -> failwith "Invalid location field"
445 in
446 let sub_parts = match List.assoc_opt "subParts" fields with
447 | Some (`List items) ->
448 Some (List.map (fun item ->
449 match of_json item with
450 | Ok part -> part
451 | Error msg -> failwith msg) items)
452 | Some `Null | None -> None
453 | _ -> failwith "Invalid subParts field"
454 in
455 let disposition_params = match List.assoc_opt "dispositionParams" fields with
456 | Some (`Assoc params) ->
457 let tbl = Hashtbl.create (List.length params) in
458 List.iter (function
459 | (k, `String v) -> Hashtbl.add tbl k v
460 | _ -> failwith "Invalid dispositionParams format"
461 ) params;
462 Some tbl
463 | Some `Null | None -> None
464 | _ -> failwith "Invalid dispositionParams field"
465 in
466 let boundary = match List.assoc_opt "boundary" fields with
467 | Some (`String s) -> Some s
468 | Some `Null | None -> None
469 | _ -> failwith "Invalid boundary field"
470 in
471 let content_transfer_encoding = match List.assoc_opt "contentTransferEncoding" fields with
472 | Some (`String s) -> Some s
473 | Some `Null | None -> None
474 | _ -> failwith "Invalid contentTransferEncoding field"
475 in
476 let other_headers = Hashtbl.create 0 in
477 (* Add any fields not in the standard set to other_headers *)
478 let standard_fields = [
479 "size"; "headers"; "type"; "partId"; "blobId"; "name";
480 "charset"; "disposition"; "dispositionParams"; "cid"; "language"; "location"; "subParts";
481 "boundary"; "contentTransferEncoding"
482 ] in
483 List.iter (fun (k, v) ->
484 if not (List.mem k standard_fields) then
485 Hashtbl.add other_headers k v
486 ) fields;
487 Ok {
488 id; blob_id; size; headers; name; mime_type; charset;
489 disposition; disposition_params; cid; language; location; sub_parts; boundary;
490 content_transfer_encoding; other_headers
491 }
492 with
493 | Failure msg -> Error msg
494 | exn -> Error (Printexc.to_string exn))
495 | _ ->
496 Error "Body part JSON must be an object"
497
498module Value = struct
499 type t = {
500 value : string;
501 has_encoding_problem : bool;
502 is_truncated : bool;
503 }
504
505 let value t = t.value
506 let has_encoding_problem t = t.has_encoding_problem
507 let is_truncated t = t.is_truncated
508
509 let create ~value ?(encoding_problem = false) ?(truncated = false) () =
510 {
511 value;
512 has_encoding_problem = encoding_problem;
513 is_truncated = truncated
514 }
515
516 (** Create from raw MIME part content with full decoding *)
517 let from_mime_part ~part_content ~content_type ~content_transfer_encoding ~max_bytes () =
518 let params = MIME_params.parse_parameters (Option.value content_type ~default:"text/plain") in
519 let charset = MIME_params.find_param params "charset" in
520 let (decoded_content, encoding_problem) =
521 Encoding.decode_content content_transfer_encoding part_content in
522
523 (* Apply size limit if specified *)
524 let (final_content, is_truncated) =
525 if max_bytes > 0 && String.length decoded_content > max_bytes then
526 (String.sub decoded_content 0 max_bytes, true)
527 else
528 (decoded_content, false)
529 in
530
531 (* TODO: Character set conversion would go here if implementing full charset support *)
532 let _ = charset in (* Acknowledge parameter to avoid warning *)
533
534 {
535 value = final_content;
536 has_encoding_problem = encoding_problem;
537 is_truncated
538 }
539
540 (** Check if body value contains text content suitable for display *)
541 let is_text_content (t : t) : bool =
542 not (String.trim t.value = "")
543
544 (** Get content length in bytes *)
545 let content_length (t : t) : int =
546 String.length t.value
547
548 (** Get content preview (first N characters) *)
549 let preview (t : t) ~max_chars : string =
550 if String.length t.value <= max_chars then
551 t.value
552 else
553 String.sub t.value 0 max_chars ^ "..."
554
555 let to_json t =
556 let fields = [("value", `String t.value)] in
557 let fields = if t.has_encoding_problem then
558 ("isEncodingProblem", `Bool true) :: fields
559 else fields in
560 let fields = if t.is_truncated then
561 ("isTruncated", `Bool true) :: fields
562 else fields in
563 `Assoc fields
564
565 let of_json = function
566 | `Assoc fields ->
567 (try
568 let value = match List.assoc_opt "value" fields with
569 | Some (`String v) -> v
570 | _ -> failwith "Missing or invalid value field"
571 in
572 let has_encoding_problem = match List.assoc_opt "isEncodingProblem" fields with
573 | Some (`Bool b) -> b
574 | Some `Null | None -> false
575 | _ -> failwith "Invalid isEncodingProblem field"
576 in
577 let is_truncated = match List.assoc_opt "isTruncated" fields with
578 | Some (`Bool b) -> b
579 | Some `Null | None -> false
580 | _ -> failwith "Invalid isTruncated field"
581 in
582 Ok { value; has_encoding_problem; is_truncated }
583 with
584 | Failure msg -> Error msg
585 | exn -> Error (Printexc.to_string exn))
586 | _ ->
587 Error "Body value JSON must be an object"
588end
589
590let pp fmt t =
591 Format.fprintf fmt "BodyPart{id=%s;mime_type=%s;size=%d;multipart=%b}"
592 (match t.id with Some s -> s | None -> "none")
593 t.mime_type
594 (Jmap.UInt.to_int t.size)
595 (is_multipart t)
596
597let pp_hum fmt t = pp fmt t