My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** Email address representation and address groups implementation.
2
3 This module implements email addresses and address groups with proper
4 validation and JSON serialization support as specified in RFC 8621.
5
6 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.2.3> RFC 8621, Section 4.1.2.3
7*)
8
9type t = {
10 name : string option;
11 email : string;
12}
13
14type address = t
15
16let name t = t.name
17let email t = t.email
18
19(* Basic email validation - checks for @ symbol and basic structure *)
20let validate_email email =
21 let len = String.length email in
22 if len = 0 then
23 Error "Email address cannot be empty"
24 else if not (String.contains email '@') then
25 Error "Email address must contain @ symbol"
26 else
27 let at_pos = String.rindex email '@' in
28 if at_pos = 0 then
29 Error "Email address cannot start with @"
30 else if at_pos = len - 1 then
31 Error "Email address cannot end with @"
32 else if String.contains_from email (at_pos + 1) '@' then
33 Error "Email address cannot contain multiple @ symbols"
34 else
35 Ok ()
36
37let create ?name ~email () =
38 match validate_email email with
39 | Ok () -> Ok { name; email }
40 | Error msg -> Error msg
41
42let create_unsafe ?name ~email () = { name; email }
43
44let to_json t =
45 let fields = [("email", `String t.email)] in
46 let fields = match t.name with
47 | Some name -> ("name", `String name) :: fields
48 | None -> fields
49 in
50 `Assoc fields
51
52let of_json = function
53 | `Assoc fields ->
54 (match List.assoc_opt "email" fields with
55 | Some (`String email) ->
56 let name = match List.assoc_opt "name" fields with
57 | Some (`String name) -> Some name
58 | Some `Null | None -> None
59 | Some _ -> failwith "Invalid name field type"
60 in
61 (match validate_email email with
62 | Ok () -> Ok { name; email }
63 | Error msg -> Error ("Invalid email address: " ^ msg))
64 | Some _ -> Error "Email field must be a string"
65 | None -> Error "Missing required email field")
66 | _ -> Error "Email address must be a JSON object"
67
68let pp ppf t =
69 match t.name with
70 | Some name -> Format.fprintf ppf "%s <%s>" name t.email
71 | None -> Format.fprintf ppf "%s" t.email
72
73let pp_hum = pp
74
75module Group = struct
76 type t = {
77 name : string option;
78 addresses : address list;
79 }
80
81 let name t = t.name
82 let addresses t = t.addresses
83
84 let create ?name ~addresses () = { name; addresses }
85
86 let to_json t =
87 let fields = [("addresses", `List (List.map to_json t.addresses))] in
88 let fields = match t.name with
89 | Some name -> ("name", `String name) :: fields
90 | None -> fields
91 in
92 `Assoc fields
93
94 let of_json = function
95 | `Assoc fields ->
96 (match List.assoc_opt "addresses" fields with
97 | Some (`List addr_list) ->
98 let parse_addresses acc_result addr_json =
99 match acc_result with
100 | Error _ as err -> err
101 | Ok acc_addrs ->
102 (match of_json addr_json with
103 | Ok addr -> Ok (addr :: acc_addrs)
104 | Error msg -> Error ("Invalid address in group: " ^ msg))
105 in
106 (match List.fold_left parse_addresses (Ok []) addr_list with
107 | Ok addresses ->
108 let addresses = List.rev addresses in
109 let name = match List.assoc_opt "name" fields with
110 | Some (`String name) -> Some name
111 | Some `Null | None -> None
112 | Some _ -> failwith "Invalid name field type"
113 in
114 Ok { name; addresses }
115 | Error msg -> Error msg)
116 | Some _ -> Error "Addresses field must be a JSON array"
117 | None -> Error "Missing required addresses field")
118 | _ -> Error "Address group must be a JSON object"
119
120 let pp ppf t =
121 let format_addresses addrs =
122 String.concat ", " (List.map (fun addr -> Format.asprintf "%a" pp addr) addrs)
123 in
124 match t.name with
125 | Some name -> Format.fprintf ppf "%s: %s;" name (format_addresses t.addresses)
126 | None -> Format.fprintf ppf "%s" (format_addresses t.addresses)
127
128 let pp_hum = pp
129end