My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** JMAP Email Validation Rules Implementation.
2
3 Implements comprehensive validation for JMAP email objects and ensures
4 RFC compliance for all data structures.
5*)
6
7type validation_error = [
8 | `InvalidKeyword of string * string
9 | `InvalidEmailAddress of string
10 | `InvalidSize of int * int
11 | `InvalidMailboxId of string
12 | `InvalidMessageId of string
13 | `InvalidHeader of string * string
14 | `InvalidDate of string
15 | `DuplicateRole of string
16 | `InvalidRole of string
17 | `MailboxHierarchyCycle of string list
18 | `InvalidIdentityPermission of string
19 | `InvalidSubmissionTime of string
20]
21
22let string_of_validation_error = function
23 | `InvalidKeyword (keyword, reason) -> Printf.sprintf "Invalid keyword '%s': %s" keyword reason
24 | `InvalidEmailAddress addr -> Printf.sprintf "Invalid email address: %s" addr
25 | `InvalidSize (actual, max) -> Printf.sprintf "Size %d exceeds maximum %d" actual max
26 | `InvalidMailboxId id -> Printf.sprintf "Invalid mailbox ID: %s" id
27 | `InvalidMessageId id -> Printf.sprintf "Invalid Message-ID: %s" id
28 | `InvalidHeader (name, reason) -> Printf.sprintf "Invalid header '%s': %s" name reason
29 | `InvalidDate date -> Printf.sprintf "Invalid date format: %s" date
30 | `DuplicateRole role -> Printf.sprintf "Duplicate mailbox role: %s" role
31 | `InvalidRole role -> Printf.sprintf "Invalid mailbox role: %s" role
32 | `MailboxHierarchyCycle path -> Printf.sprintf "Mailbox hierarchy cycle: %s" (String.concat " -> " path)
33 | `InvalidIdentityPermission perm -> Printf.sprintf "Invalid identity permission: %s" perm
34 | `InvalidSubmissionTime time -> Printf.sprintf "Invalid submission time: %s" time
35
36(** {1 Keywords Validation} *)
37
38let standard_keywords = [
39 "$answered"; "$flagged"; "$draft"; "$seen"; "$recent";
40 "$forwarded"; "$phishing"; "$junk"; "$notjunk"
41]
42
43let is_system_keyword keyword =
44 List.mem keyword standard_keywords
45
46let validate_keyword_format keyword =
47 (* Check maximum length *)
48 if String.length keyword > 255 then
49 Error (`InvalidKeyword (keyword, "exceeds maximum length of 255 characters"))
50 else if String.length keyword = 0 then
51 Error (`InvalidKeyword (keyword, "keyword cannot be empty"))
52 else
53 (* Check for valid characters: lowercase ASCII, no whitespace/control *)
54 let is_valid_char c =
55 let code = Char.code c in
56 (code >= 97 && code <= 122) || (* a-z *)
57 (code >= 48 && code <= 57) || (* 0-9 *)
58 code = 36 || (* $ *)
59 code = 45 || (* - *)
60 code = 95 (* _ *)
61 in
62 let invalid_chars = ref [] in
63 String.iteri (fun i c ->
64 if not (is_valid_char c) then
65 invalid_chars := (i, c) :: !invalid_chars
66 ) keyword;
67
68 match !invalid_chars with
69 | [] ->
70 (* Check if it starts with lowercase letter or $ *)
71 let first_char = keyword.[0] in
72 if first_char = '$' || (first_char >= 'a' && first_char <= 'z') then
73 Ok ()
74 else
75 Error (`InvalidKeyword (keyword, "must start with lowercase letter or $"))
76 | (i, c) :: _ ->
77 Error (`InvalidKeyword (keyword, Printf.sprintf "invalid character '%c' at position %d" c i))
78
79let validate_keywords keywords =
80 let errors = ref [] in
81 Hashtbl.iter (fun keyword _ ->
82 match validate_keyword_format keyword with
83 | Ok () -> ()
84 | Error err -> errors := err :: !errors
85 ) (Jmap_email.Keywords.to_hashtbl keywords);
86
87 match !errors with
88 | [] -> Ok ()
89 | errs -> Error (List.rev errs)
90
91(** {1 Email Address Validation} *)
92
93let validate_email_address_string addr_str =
94 (* Basic email address validation according to RFC 5322 *)
95 let email_regex =
96 Str.regexp "^[a-zA-Z0-9.!#$%&'*+/=?^_`{|}~-]+@[a-zA-Z0-9]\\([a-zA-Z0-9-]*[a-zA-Z0-9]\\)?\\(\\.[a-zA-Z0-9]\\([a-zA-Z0-9-]*[a-zA-Z0-9]\\)?\\)*$"
97 in
98 if String.length addr_str > 320 then (* RFC 5321 limit *)
99 Error (`InvalidEmailAddress "exceeds maximum length of 320 characters")
100 else if String.length addr_str = 0 then
101 Error (`InvalidEmailAddress "email address cannot be empty")
102 else if not (Str.string_match email_regex addr_str 0) then
103 Error (`InvalidEmailAddress "invalid email address format")
104 else
105 (* Check local part length (before @) *)
106 match String.index_opt addr_str '@' with
107 | Some at_pos ->
108 let local_part = String.sub addr_str 0 at_pos in
109 if String.length local_part > 64 then
110 Error (`InvalidEmailAddress "local part exceeds 64 characters")
111 else
112 Ok ()
113 | None ->
114 Error (`InvalidEmailAddress "missing @ symbol")
115
116let validate_email_address addr =
117 let addr_str = match Jmap_email.Address.email addr with
118 | Some email -> email
119 | None -> ""
120 in
121 validate_email_address_string addr_str
122
123(** {1 Size Constraints Validation} *)
124
125let validate_size_constraints email =
126 let errors = ref [] in
127
128 (* Check email size (if available) *)
129 (match Jmap_email.Email.Email.size email with
130 | Some size ->
131 let size_int = Jmap.UInt.to_int size in
132 if size_int > 50_000_000 then (* 50MB limit *)
133 errors := `InvalidSize (size_int, 50_000_000) :: !errors
134 | None -> ());
135
136 (* Check subject length *)
137 (match Jmap_email.Email.Email.subject email with
138 | Some subject ->
139 if String.length subject > 10000 then (* Reasonable subject limit *)
140 errors := `InvalidSize (String.length subject, 10000) :: !errors
141 | None -> ());
142
143 (* Check attachment count *)
144 (match Jmap_email.Email.Email.attachments email with
145 | Some attachments ->
146 let count = List.length attachments in
147 if count > 100 then (* Reasonable attachment limit *)
148 errors := `InvalidSize (count, 100) :: !errors
149 | None -> ());
150
151 match !errors with
152 | [] -> Ok ()
153 | errs -> Error (List.rev errs)
154
155let validate_mailbox_name_size name =
156 if String.length name > 255 then
157 Error (`InvalidSize (String.length name, 255))
158 else if String.length name = 0 then
159 Error (`InvalidSize (0, 1)) (* Name cannot be empty *)
160 else
161 Ok ()
162
163(** {1 Mailbox Validation} *)
164
165let validate_mailbox_role_uniqueness mailboxes =
166 let role_counts = Hashtbl.create 10 in
167 let errors = ref [] in
168
169 List.iter (fun mailbox ->
170 match Jmap_email.Mailbox.Mailbox.role mailbox with
171 | Some role ->
172 let role_str = Jmap_email.Mailbox.Role.to_string role in
173 let current_count = try Hashtbl.find role_counts role_str with Not_found -> 0 in
174 if current_count > 0 then
175 errors := `DuplicateRole role_str :: !errors;
176 Hashtbl.replace role_counts role_str (current_count + 1)
177 | None -> ()
178 ) mailboxes;
179
180 match !errors with
181 | [] -> Ok ()
182 | errs -> Error (List.rev errs)
183
184let validate_mailbox_hierarchy mailboxes =
185 (* Build parent-child map *)
186 let parent_map = Hashtbl.create 50 in
187 let id_to_name = Hashtbl.create 50 in
188
189 List.iter (fun mailbox ->
190 match Jmap_email.Mailbox.Mailbox.id mailbox with
191 | Some id ->
192 let id_str = Jmap.Id.to_string id in
193 let name = match Jmap_email.Mailbox.Mailbox.name mailbox with
194 | Some n -> n
195 | None -> id_str
196 in
197 Hashtbl.add id_to_name id_str name;
198
199 (match Jmap_email.Mailbox.Mailbox.parent_id mailbox with
200 | Some parent_id ->
201 let parent_str = Jmap.Id.to_string parent_id in
202 Hashtbl.add parent_map id_str parent_str
203 | None -> ())
204 | None -> ()
205 ) mailboxes;
206
207 (* Detect cycles using DFS *)
208 let visited = Hashtbl.create 50 in
209 let rec_stack = Hashtbl.create 50 in
210 let errors = ref [] in
211
212 let rec dfs_cycle_check node path =
213 if Hashtbl.mem rec_stack node then
214 (* Found cycle *)
215 let cycle_path = node :: path in
216 let cycle_names = List.map (fun id ->
217 try Hashtbl.find id_to_name id
218 with Not_found -> id
219 ) cycle_path in
220 errors := `MailboxHierarchyCycle cycle_names :: !errors
221 else if not (Hashtbl.mem visited node) then begin
222 Hashtbl.add visited node true;
223 Hashtbl.add rec_stack node true;
224
225 (try
226 let parent = Hashtbl.find parent_map node in
227 dfs_cycle_check parent (node :: path)
228 with Not_found -> ());
229
230 Hashtbl.remove rec_stack node
231 end
232 in
233
234 Hashtbl.iter (fun node _ ->
235 if not (Hashtbl.mem visited node) then
236 dfs_cycle_check node []
237 ) id_to_name;
238
239 match !errors with
240 | [] -> Ok ()
241 | errs -> Error (List.rev errs)
242
243let validate_mailbox_name_collisions mailboxes =
244 let name_map = Hashtbl.create 50 in
245 let errors = ref [] in
246
247 List.iter (fun mailbox ->
248 match Jmap_email.Mailbox.Mailbox.name mailbox with
249 | Some name ->
250 let parent_str = match Jmap_email.Mailbox.Mailbox.parent_id mailbox with
251 | Some parent_id -> Jmap.Id.to_string parent_id
252 | None -> "root"
253 in
254 let full_path = parent_str ^ "/" ^ name in
255
256 if Hashtbl.mem name_map full_path then
257 errors := `InvalidRole ("name collision: " ^ name) :: !errors
258 else
259 Hashtbl.add name_map full_path true
260 | None -> ()
261 ) mailboxes;
262
263 match !errors with
264 | [] -> Ok ()
265 | errs -> Error (List.rev errs)
266
267(** {1 Email Submission Validation} *)
268
269let validate_smtp_envelope envelope =
270 let errors = ref [] in
271
272 (* Validate sender email *)
273 (match Jmap_email.Submission.Envelope.mail_from envelope with
274 | Some sender ->
275 (match validate_email_address_string sender with
276 | Error err -> errors := err :: !errors
277 | Ok () -> ())
278 | None ->
279 errors := `InvalidEmailAddress "SMTP envelope must have mail_from" :: !errors);
280
281 (* Validate recipient emails *)
282 let recipients = Jmap_email.Submission.Envelope.rcpt_to envelope in
283 List.iter (fun recipient ->
284 match validate_email_address_string recipient with
285 | Error err -> errors := err :: !errors
286 | Ok () -> ()
287 ) recipients;
288
289 (* Check recipient count *)
290 if List.length recipients = 0 then
291 errors := `InvalidEmailAddress "SMTP envelope must have at least one recipient" :: !errors;
292
293 if List.length recipients > 100 then (* Reasonable limit *)
294 errors := `InvalidSize (List.length recipients, 100) :: !errors;
295
296 match !errors with
297 | [] -> Ok ()
298 | errs -> Error (List.rev errs)
299
300let validate_send_time_constraints send_at =
301 match send_at with
302 | None -> Ok ()
303 | Some send_time ->
304 let now = Unix.time () in
305 let send_timestamp = Jmap.Date.to_timestamp send_time in
306
307 (* Don't allow sending emails too far in the future (1 year) *)
308 if send_timestamp > now +. (365.0 *. 24.0 *. 3600.0) then
309 Error (`InvalidSubmissionTime "send time too far in future")
310 (* Don't allow sending emails in the past (with 5 minute tolerance) *)
311 else if send_timestamp < now -. 300.0 then
312 Error (`InvalidSubmissionTime "send time cannot be in the past")
313 else
314 Ok ()
315
316let validate_identity_permission identity sender_email =
317 match Jmap_email.Identity.Identity.email identity with
318 | Some identity_email ->
319 if identity_email = sender_email then
320 Ok ()
321 else
322 Error (`InvalidIdentityPermission ("identity email does not match sender: " ^ identity_email ^ " vs " ^ sender_email))
323 | None ->
324 Error (`InvalidIdentityPermission "identity must have an email address")
325
326(** {1 Header Validation} *)
327
328let validate_header header =
329 let name = Jmap_email.Header.name header in
330 let value = Jmap_email.Header.value header in
331
332 (* Check header name format *)
333 let name_errors =
334 if String.length name = 0 then
335 [`InvalidHeader (name, "header name cannot be empty")]
336 else if String.length name > 255 then
337 [`InvalidHeader (name, "header name too long")]
338 else
339 (* Check for valid header name characters *)
340 let invalid_chars = ref [] in
341 String.iteri (fun i c ->
342 let code = Char.code c in
343 if not ((code >= 33 && code <= 126) && code <> 58) then (* Printable ASCII except : *)
344 invalid_chars := (i, c) :: !invalid_chars
345 ) name;
346 match !invalid_chars with
347 | [] -> []
348 | (i, c) :: _ -> [`InvalidHeader (name, Printf.sprintf "invalid character '%c' at position %d" c i)]
349 in
350
351 (* Check header value length *)
352 let value_errors =
353 if String.length value > 10000 then (* Reasonable header value limit *)
354 [`InvalidHeader (name, "header value too long")]
355 else
356 []
357 in
358
359 match name_errors @ value_errors with
360 | [] -> Ok ()
361 | err :: _ -> Error err
362
363let validate_message_id message_id =
364 (* Basic Message-ID format: <unique@domain> *)
365 let msg_id_regex = Str.regexp "^<[^<>@]+@[^<>@]+>$" in
366 if String.length message_id > 255 then
367 Error (`InvalidMessageId "Message-ID too long")
368 else if not (Str.string_match msg_id_regex message_id 0) then
369 Error (`InvalidMessageId "invalid Message-ID format, must be <unique@domain>")
370 else
371 Ok ()
372
373let validate_references references =
374 (* References should be space-separated Message-IDs *)
375 let msg_ids = String.split_on_char ' ' references in
376 let filtered_ids = List.filter (fun s -> String.length s > 0) msg_ids in
377
378 let rec validate_all = function
379 | [] -> Ok ()
380 | id :: rest ->
381 (match validate_message_id id with
382 | Ok () -> validate_all rest
383 | Error err -> Error err)
384 in
385
386 if List.length filtered_ids > 50 then (* Reasonable limit on references *)
387 Error (`InvalidMessageId "too many references (maximum 50)")
388 else
389 validate_all filtered_ids
390
391(** {1 Date Validation} *)
392
393let validate_date_string date_str =
394 (* Try to parse the date string *)
395 try
396 let _ = Jmap.Date.of_string date_str in
397 Ok ()
398 with
399 | _ -> Error (`InvalidDate ("cannot parse date: " ^ date_str))
400
401let validate_date date =
402 let timestamp = Jmap.Date.to_timestamp date in
403 (* Check reasonable date range (1970 to 2100) *)
404 if timestamp < 0.0 then
405 Error (`InvalidDate "date before Unix epoch")
406 else if timestamp > 4102444800.0 then (* 2100-01-01 *)
407 Error (`InvalidDate "date too far in future")
408 else
409 Ok ()
410
411(** {1 Comprehensive Validation} *)
412
413let validate_email_complete email =
414 let errors = ref [] in
415
416 (* Validate keywords *)
417 (match Jmap_email.Email.Email.keywords email with
418 | Some keywords ->
419 (match validate_keywords keywords with
420 | Error errs -> errors := errs @ !errors
421 | Ok () -> ())
422 | None -> ());
423
424 (* Validate sender addresses *)
425 (match Jmap_email.Email.Email.from email with
426 | Some from_addrs ->
427 List.iter (fun addr ->
428 match validate_email_address addr with
429 | Error err -> errors := err :: !errors
430 | Ok () -> ()
431 ) from_addrs
432 | None -> ());
433
434 (* Validate recipient addresses *)
435 (match Jmap_email.Email.Email.to_ email with
436 | Some to_addrs ->
437 List.iter (fun addr ->
438 match validate_email_address addr with
439 | Error err -> errors := err :: !errors
440 | Ok () -> ()
441 ) to_addrs
442 | None -> ());
443
444 (* Validate size constraints *)
445 (match validate_size_constraints email with
446 | Error errs -> errors := errs @ !errors
447 | Ok () -> ());
448
449 (* Validate date *)
450 (match Jmap_email.Email.Email.received_at email with
451 | Some date ->
452 (match validate_date date with
453 | Error err -> errors := err :: !errors
454 | Ok () -> ())
455 | None -> ());
456
457 match !errors with
458 | [] -> Ok ()
459 | errs -> Error (List.rev errs)
460
461let validate_mailbox_complete mailbox =
462 let errors = ref [] in
463
464 (* Validate name *)
465 (match Jmap_email.Mailbox.Mailbox.name mailbox with
466 | Some name ->
467 (match validate_mailbox_name_size name with
468 | Error err -> errors := err :: !errors
469 | Ok () -> ())
470 | None ->
471 errors := `InvalidSize (0, 1) :: !errors); (* Name required *)
472
473 (* Additional mailbox validations would go here *)
474
475 match !errors with
476 | [] -> Ok ()
477 | errs -> Error (List.rev errs)
478
479let validate_submission_complete submission =
480 let errors = ref [] in
481
482 (* Validate envelope *)
483 (match Jmap_email.Submission.EmailSubmission.envelope submission with
484 | Some envelope ->
485 (match validate_smtp_envelope envelope with
486 | Error errs -> errors := errs @ !errors
487 | Ok () -> ())
488 | None -> ());
489
490 (* Validate send time *)
491 let send_at = Jmap_email.Submission.EmailSubmission.send_at submission in
492 (match validate_send_time_constraints send_at with
493 | Error err -> errors := err :: !errors
494 | Ok () -> ());
495
496 match !errors with
497 | [] -> Ok ()
498 | errs -> Error (List.rev errs)