My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** JMAP Search Snippet Implementation.
2
3 This module implements the JMAP SearchSnippet data type for providing
4 highlighted excerpts from email content that match search queries,
5 along with helper functions for text processing and filter creation.
6
7 @see <https://www.rfc-editor.org/rfc/rfc8621.html#section-5> RFC 8621, Section 5: SearchSnippet
8*)
9
10open Jmap.Methods
11
12(** SearchSnippet object *)
13module SearchSnippet = struct
14 type t = {
15 email_id : Jmap.Id.t;
16 subject : string option;
17 preview : string option;
18 }
19
20 let email_id t = t.email_id
21 let subject t = t.subject
22 let preview t = t.preview
23
24 let v ~email_id ?subject ?preview () = {
25 email_id;
26 subject;
27 preview;
28 }
29
30 let to_json t =
31 let fields = [
32 ("emailId", `String (Jmap.Id.to_string t.email_id));
33 ] in
34 let fields = match t.subject with
35 | Some s -> ("subject", `String s) :: fields
36 | None -> fields
37 in
38 let fields = match t.preview with
39 | Some p -> ("preview", `String p) :: fields
40 | None -> fields
41 in
42 `Assoc (List.rev fields)
43
44 let of_json = function
45 | `Assoc fields ->
46 (match List.assoc_opt "emailId" fields with
47 | Some (`String email_id_str) ->
48 let email_id = match Jmap.Id.of_string email_id_str with
49 | Ok id -> id
50 | Error _ -> failwith ("Invalid email ID: " ^ email_id_str) in
51 let subject = match List.assoc_opt "subject" fields with
52 | Some (`String s) -> Some s
53 | Some `Null | None -> None
54 | _ -> failwith "Invalid subject field"
55 in
56 let preview = match List.assoc_opt "preview" fields with
57 | Some (`String p) -> Some p
58 | Some `Null | None -> None
59 | _ -> failwith "Invalid preview field"
60 in
61 Ok { email_id; subject; preview }
62 | _ -> Error "Missing or invalid emailId field")
63 | _ -> Error "SearchSnippet must be a JSON object"
64
65 let pp ppf t =
66 Format.fprintf ppf "SearchSnippet{emailId=%s; subject=%s; preview=%s}"
67 (Jmap.Id.to_string t.email_id)
68 (match t.subject with Some s -> "\"" ^ s ^ "\"" | None -> "None")
69 (match t.preview with Some p -> "\"" ^ String.sub p 0 (Int.min 50 (String.length p)) ^ "...\"" | None -> "None")
70
71 let pp_hum = pp
72end
73
74(** Arguments for SearchSnippet/get *)
75module Get_args = struct
76 type t = {
77 account_id : Jmap.Id.t;
78 filter : Filter.t;
79 email_ids : Jmap.Id.t list option;
80 }
81
82 let account_id t = t.account_id
83 let filter t = t.filter
84 let email_ids t = t.email_ids
85
86 let v ~account_id ~filter ?email_ids () = {
87 account_id;
88 filter;
89 email_ids;
90 }
91
92 let to_json t =
93 let fields = [
94 ("accountId", `String (Jmap.Id.to_string t.account_id));
95 ("filter", Filter.to_json t.filter);
96 ] in
97 let fields = match t.email_ids with
98 | Some ids -> ("emailIds", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) ids)) :: fields
99 | None -> fields
100 in
101 `Assoc fields
102
103 let of_json json =
104 try
105 match json with
106 | `Assoc fields ->
107 let account_id = match List.assoc_opt "accountId" fields with
108 | Some (`String id) -> (match Jmap.Id.of_string id with
109 | Ok id -> id
110 | Error err -> failwith ("Invalid accountId: " ^ err))
111 | _ -> failwith "Missing or invalid accountId"
112 in
113 let filter = match List.assoc_opt "filter" fields with
114 | Some filter_json -> Filter.condition filter_json
115 | _ -> failwith "Missing or invalid filter"
116 in
117 let email_ids = match List.assoc_opt "emailIds" fields with
118 | Some (`List ids) -> Some (List.map (function `String id -> (match Jmap.Id.of_string id with Ok id -> id | Error err -> failwith ("Invalid email ID: " ^ err)) | _ -> failwith "Invalid email ID") ids)
119 | Some `Null | None -> None
120 | _ -> failwith "Invalid emailIds field"
121 in
122 Ok { account_id; filter; email_ids }
123 | _ -> failwith "Expected JSON object"
124 with
125 | Failure msg -> Error msg
126 | exn -> Error (Printexc.to_string exn)
127
128 let pp fmt t =
129 Format.fprintf fmt "SearchSnippet.Get_args{account=%s;emails=%s}"
130 (Jmap.Id.to_string t.account_id)
131 (match t.email_ids with Some ids -> string_of_int (List.length ids) | None -> "all")
132
133 let pp_hum fmt t = pp fmt t
134end
135
136(** Response for SearchSnippet/get *)
137module Get_response = struct
138 type t = {
139 account_id : Jmap.Id.t;
140 list : (string, SearchSnippet.t) Hashtbl.t;
141 not_found : Jmap.Id.t list;
142 }
143
144 let account_id t = t.account_id
145 let list t = t.list
146 let not_found t = t.not_found
147
148 let v ~account_id ~list ~not_found () = {
149 account_id;
150 list;
151 not_found;
152 }
153
154 let to_json t =
155 `Assoc [
156 ("accountId", `String (Jmap.Id.to_string t.account_id));
157 ("list", `Assoc (Hashtbl.fold (fun k v acc -> (k, SearchSnippet.to_json v) :: acc) t.list []));
158 ("notFound", `List (List.map (fun id -> `String (Jmap.Id.to_string id)) t.not_found));
159 ]
160
161 let of_json json =
162 try
163 match json with
164 | `Assoc fields ->
165 let account_id = match List.assoc_opt "accountId" fields with
166 | Some (`String id_str) -> (match Jmap.Id.of_string id_str with
167 | Ok id -> id
168 | Error _ -> failwith ("Invalid account ID: " ^ id_str))
169 | _ -> failwith "Missing or invalid accountId"
170 in
171 let list = Hashtbl.create 16 in
172 let not_found = match List.assoc_opt "notFound" fields with
173 | Some (`List ids) -> List.map (function
174 | `String id_str -> (match Jmap.Id.of_string id_str with
175 | Ok id -> id
176 | Error _ -> failwith ("Invalid ID: " ^ id_str))
177 | _ -> failwith "Invalid not found ID") ids
178 | Some `Null | None -> []
179 | _ -> failwith "Invalid notFound field"
180 in
181 Ok { account_id; list; not_found }
182 | _ -> failwith "Expected JSON object"
183 with
184 | Failure msg -> Error msg
185 | exn -> Error (Printexc.to_string exn)
186
187 let pp fmt t =
188 Format.fprintf fmt "SearchSnippet.Get_response{account=%s;found=%d;not_found=%d}"
189 (Jmap.Id.to_string t.account_id)
190 (Hashtbl.length t.list)
191 (List.length t.not_found)
192
193 let pp_hum fmt t = pp fmt t
194end
195
196(** Helper to extract all matched keywords from a snippet *)
197let extract_matched_terms snippet =
198 (* Simple implementation: look for highlighted terms between markers
199 Assuming highlight markers are like <mark>term</mark> *)
200 let rec extract acc pos =
201 try
202 let start_pos = String.index_from snippet pos '<' in
203 if start_pos + 5 < String.length snippet &&
204 String.sub snippet start_pos 6 = "<mark>" then
205 let end_pos = String.index_from snippet (start_pos + 6) '<' in
206 if end_pos + 6 < String.length snippet &&
207 String.sub snippet end_pos 7 = "</mark>" then
208 let term = String.sub snippet (start_pos + 6) (end_pos - start_pos - 6) in
209 extract (term :: acc) (end_pos + 7)
210 else
211 extract acc (start_pos + 1)
212 else
213 extract acc (start_pos + 1)
214 with Not_found -> List.rev acc
215 in
216 extract [] 0
217
218(** Helper to create a filter that searches in email body text *)
219let create_body_text_filter text =
220 Filter.condition (`Assoc [
221 ("text", `String text);
222 ("area", `String "body")
223 ])
224
225(** Helper to create a filter that searches across multiple email fields *)
226let create_fulltext_filter text =
227 Filter.condition (`Assoc [
228 ("text", `String text)
229 ])