This repository has no description
1(*---------------------------------------------------------------------------
2 JMAP Email Client - Browser Application
3 Built with OCaml, Brr, and jmap-brr
4 ---------------------------------------------------------------------------*)
5
6open Brr
7open Fut.Syntax
8
9(* ---- Shared timestamp utilities ---- *)
10
11let get_time_str () =
12 let date = Jv.new' (Jv.get Jv.global "Date") [||] in
13 let h = Jv.to_int (Jv.call date "getHours" [||]) in
14 let m = Jv.to_int (Jv.call date "getMinutes" [||]) in
15 let s = Jv.to_int (Jv.call date "getSeconds" [||]) in
16 Printf.sprintf "%02d:%02d:%02d" h m s
17
18(* ---- JSON Masking ---- *)
19
20module JsonMask = struct
21 let sensitive_keys = [
22 "accountId"; "blobId"; "threadId"; "emailId"; "id";
23 "username"; "apiUrl"; "downloadUrl"; "uploadUrl"; "eventSourceUrl";
24 "state"; "oldState"; "newState"
25 ]
26
27 let is_sensitive key =
28 List.exists (fun k -> String.lowercase_ascii k = String.lowercase_ascii key) sensitive_keys
29
30 let mask_value s =
31 let len = String.length s in
32 if len <= 4 then String.make len '*'
33 else
34 let visible = min 4 (len / 4) in
35 (String.sub s 0 visible) ^ String.make (len - visible) '*'
36
37 let rec mask_json (json : Jv.t) : Jv.t =
38 if Jv.is_null json || Jv.is_undefined json then json
39 else if Jv.is_array json then
40 let arr = Jv.to_list Fun.id json in
41 let masked = List.map mask_json arr in
42 Jv.of_list Fun.id masked
43 else if Jstr.equal (Jv.typeof json) (Jstr.v "object") && not (Jv.is_array json) then
44 let obj = Jv.obj [||] in
45 let keys = Jv.call (Jv.get Jv.global "Object") "keys" [|json|] in
46 let key_list = Jv.to_list Jv.to_string keys in
47 List.iter (fun key ->
48 let value = Jv.get json key in
49 let masked_value =
50 if is_sensitive key && Jstr.equal (Jv.typeof value) (Jstr.v "string") then
51 Jv.of_string (mask_value (Jv.to_string value))
52 else
53 mask_json value
54 in
55 Jv.set obj key masked_value
56 ) key_list;
57 obj
58 else
59 json
60
61 let format_json json =
62 let json_obj = Jv.get Jv.global "JSON" in
63 Jv.to_string (Jv.call json_obj "stringify" [|json; Jv.null; Jv.of_int 2|])
64
65 let mask_and_format json_str =
66 try
67 let json_obj = Jv.get Jv.global "JSON" in
68 let parsed = Jv.call json_obj "parse" [|Jv.of_string json_str|] in
69 let masked = mask_json parsed in
70 format_json masked
71 with _ -> json_str
72end
73
74(* ---- Logging with expandable JSON ---- *)
75
76module Log = struct
77 type level = Info | Success | Error | Warning
78
79 let log_entries_el () =
80 Document.find_el_by_id G.document (Jstr.v "log-entries")
81
82 (* Reference to the last created entry for attaching JSON *)
83 let last_entry : El.t option ref = ref None
84
85 let add level msg =
86 match log_entries_el () with
87 | None -> Console.(log [str msg])
88 | Some container ->
89 let time_str = get_time_str () in
90 let class_name = match level with
91 | Info -> "log-info"
92 | Success -> "log-success"
93 | Error -> "log-error"
94 | Warning -> "log-warning"
95 in
96 let header = El.div ~at:At.[class' (Jstr.v "log-entry-header")] [
97 El.span ~at:At.[class' (Jstr.v "log-time")] [El.txt' time_str];
98 El.span ~at:At.[class' (Jstr.v "log-message")] [El.txt' msg];
99 ] in
100 let entry = El.div ~at:At.[class' (Jstr.v ("log-entry " ^ class_name))] [header] in
101 last_entry := Some entry;
102 El.append_children container [entry];
103 (* Scroll to bottom *)
104 let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in
105 Jv.set (El.to_jv container) "scrollTop" scroll_height
106
107 let attach_json direction label json_str =
108 match !last_entry with
109 | None -> ()
110 | Some entry ->
111 let formatted = JsonMask.mask_and_format json_str in
112 let class_name = match direction with
113 | `Request -> "log-json request"
114 | `Response -> "log-json response"
115 in
116 let arrow = match direction with
117 | `Request -> ">>> "
118 | `Response -> "<<< "
119 in
120 (* Create the JSON container (hidden by default) *)
121 let json_body = El.pre ~at:At.[class' (Jstr.v "log-json-body collapsed")] [El.txt' formatted] in
122 let expand_size_btn = El.button ~at:At.[class' (Jstr.v "json-toggle-size")] [El.txt' "[expand]"] in
123 let json_div = El.div ~at:At.[class' (Jstr.v class_name)] [
124 El.div ~at:At.[class' (Jstr.v "log-json-header")] [
125 El.span [El.txt' (arrow ^ label)];
126 expand_size_btn;
127 ];
128 json_body;
129 ] in
130 (* Add expand button to header if not already there *)
131 let header = El.children entry |> List.hd in
132 let existing_btns = El.children header |> List.filter (fun el ->
133 match El.at (Jstr.v "class") el with
134 | Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-expand-btn") cls)
135 | None -> false
136 ) in
137 if List.length existing_btns = 0 then begin
138 let expand_btn = El.button ~at:At.[class' (Jstr.v "log-expand-btn")] [El.txt' "JSON"] in
139 El.append_children header [expand_btn];
140 (* Toggle visibility on click *)
141 ignore @@ Ev.listen Ev.click (fun _ev ->
142 let json_els = El.children entry |> List.filter (fun el ->
143 match El.at (Jstr.v "class") el with
144 | Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-json") cls)
145 | None -> false
146 ) in
147 let is_visible = List.exists (fun el ->
148 El.class' (Jstr.v "visible") el
149 ) json_els in
150 List.iter (fun el ->
151 El.set_class (Jstr.v "visible") (not is_visible) el
152 ) json_els;
153 El.set_class (Jstr.v "expanded") (not is_visible) expand_btn
154 ) (El.as_target expand_btn)
155 end;
156 (* Toggle body size *)
157 ignore @@ Ev.listen Ev.click (fun _ev ->
158 let is_collapsed = El.class' (Jstr.v "collapsed") json_body in
159 El.set_class (Jstr.v "collapsed") (not is_collapsed) json_body;
160 El.set_children expand_size_btn [El.txt' (if is_collapsed then "[collapse]" else "[expand]")]
161 ) (El.as_target expand_size_btn);
162 El.append_children entry [json_div];
163 (* Scroll to bottom *)
164 match log_entries_el () with
165 | Some container ->
166 let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in
167 Jv.set (El.to_jv container) "scrollTop" scroll_height
168 | None -> ()
169
170 let info msg = add Info msg
171 let success msg = add Success msg
172 let error msg = add Error msg
173 let warning msg = add Warning msg
174end
175
176(* ---- JSON Protocol Logging (bridges to Log.attach_json) ---- *)
177
178module JsonLog = struct
179 let request label json = Log.attach_json `Request label json
180 let response label json = Log.attach_json `Response label json
181 let clear () = () (* No longer needed *)
182end
183
184(* ---- DOM Helpers ---- *)
185
186let get_el id =
187 match Document.find_el_by_id G.document (Jstr.v id) with
188 | Some el -> el
189 | None -> failwith (Printf.sprintf "Element not found: %s" id)
190
191let get_input_value id =
192 let el = get_el id in
193 Jstr.to_string (El.prop El.Prop.value el)
194
195let set_text id text =
196 let el = get_el id in
197 El.set_children el [El.txt' text]
198
199let show_el id =
200 let el = get_el id in
201 El.set_class (Jstr.v "visible") true el
202
203let hide_el id =
204 let el = get_el id in
205 El.set_class (Jstr.v "visible") false el
206
207let set_button_loading id loading =
208 let el = get_el id in
209 El.set_at At.Name.disabled (if loading then Some (Jstr.v "") else None) el;
210 if loading then
211 El.set_children el [
212 El.span ~at:At.[class' (Jstr.v "spinner")] [];
213 El.txt' "Connecting..."
214 ]
215 else
216 El.set_children el [El.txt' "Connect"]
217
218(* ---- Email Display ---- *)
219
220let format_date ptime =
221 let date, time = Ptime.to_date_time ptime in
222 let y, m, d = date in
223 let (h, min, _), _ = time in
224 Printf.sprintf "%04d-%02d-%02d %02d:%02d" y m d h min
225
226let format_address (addr : Jmap.Proto.Email_address.t) =
227 match addr.name with
228 | Some name -> Printf.sprintf "%s <%s>" name addr.email
229 | None -> addr.email
230
231let format_addresses = function
232 | None -> "Unknown"
233 | Some [] -> "Unknown"
234 | Some (addr :: _) -> format_address addr
235
236let render_email (email : Jmap.Proto.Email.t) =
237 let keywords = Option.value ~default:[] email.keywords in
238 let is_unread = not (List.exists (fun (k, v) -> k = "$seen" && v) keywords) in
239 let is_flagged = List.exists (fun (k, v) -> k = "$flagged" && v) keywords in
240
241 let from_str = format_addresses email.from in
242 let subject = Option.value ~default:"(No Subject)" email.subject in
243 let date_str = match email.received_at with Some t -> format_date t | None -> "?" in
244 let preview = Option.value ~default:"" email.preview in
245
246 let keyword_tags =
247 if is_flagged then
248 [El.span ~at:At.[class' (Jstr.v "keyword-tag flagged")] [El.txt' "Flagged"]]
249 else
250 []
251 in
252
253 let classes = "email-item" ^ (if is_unread then " unread" else "") in
254
255 El.div ~at:At.[class' (Jstr.v classes)] [
256 El.div ~at:At.[class' (Jstr.v "email-header")] [
257 El.span ~at:At.[class' (Jstr.v "email-from")] [El.txt' from_str];
258 El.span ~at:At.[class' (Jstr.v "email-date")] [El.txt' date_str];
259 ];
260 El.div ~at:At.[class' (Jstr.v "email-subject")] [El.txt' subject];
261 El.div ~at:At.[class' (Jstr.v "email-preview")] [El.txt' preview];
262 El.div ~at:At.[class' (Jstr.v "email-keywords")] keyword_tags;
263 ]
264
265let display_emails emails =
266 let container = get_el "emails" in
267 let email_els = List.map render_email emails in
268 El.set_children container email_els;
269 show_el "email-list"
270
271(* ---- State ---- *)
272
273type state = {
274 mutable connection : Jmap_brr.connection option;
275 mutable account_id : Jmap.Proto.Id.t option;
276}
277
278let state = { connection = None; account_id = None }
279
280(* ---- JMAP Operations ---- *)
281
282let fetch_emails ?(search_text="") conn account_id =
283 let search_msg = if search_text = "" then "Fetching recent emails..."
284 else Printf.sprintf "Searching emails for '%s'..." search_text in
285 Log.info search_msg;
286
287 let capabilities = [
288 Jmap.Capability.core_uri;
289 Jmap.Capability.mail_uri
290 ] in
291
292 (* First, get mailboxes to find the inbox *)
293 let request, mailbox_handle =
294 let open Jmap.Chain in
295 build ~capabilities (mailbox_get ~account_id ())
296 in
297
298 let* response = Jmap_brr.request conn request in
299 match response with
300 | Error e ->
301 Log.error (Printf.sprintf "Failed to get mailboxes: %s"
302 (Jstr.to_string (Jv.Error.message e)));
303 Fut.return ()
304 | Ok resp ->
305 match Jmap.Chain.parse mailbox_handle resp with
306 | Error e ->
307 Log.error (Printf.sprintf "Failed to parse mailboxes: %s"
308 (Jsont.Error.to_string e));
309 Fut.return ()
310 | Ok mailbox_resp ->
311 let mailboxes = mailbox_resp.list in
312 Log.info (Printf.sprintf "Found %d mailboxes" (List.length mailboxes));
313
314 (* Find inbox or use first mailbox *)
315 let inbox_id =
316 match List.find_opt (fun m ->
317 match m.Jmap.Proto.Mailbox.role with
318 | Some `Inbox -> true
319 | _ -> false
320 ) mailboxes with
321 | Some m -> m.Jmap.Proto.Mailbox.id
322 | None ->
323 match mailboxes with
324 | m :: _ -> m.Jmap.Proto.Mailbox.id
325 | [] ->
326 Log.error "No mailboxes found";
327 failwith "No mailboxes"
328 in
329 let inbox_id = match inbox_id with
330 | Some id -> id
331 | None ->
332 Log.error "Inbox has no ID";
333 failwith "Inbox has no ID"
334 in
335
336 let query_msg = if search_text = "" then "Querying emails from inbox..."
337 else Printf.sprintf "Querying inbox for '%s'..." search_text in
338 Log.info query_msg;
339
340 (* Query for recent emails with optional text search *)
341 let text_filter = if search_text = "" then None else Some search_text in
342 let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
343 in_mailbox = Some inbox_id;
344 in_mailbox_other_than = None;
345 before = None;
346 after = None;
347 min_size = None;
348 max_size = None;
349 all_in_thread_have_keyword = None;
350 some_in_thread_have_keyword = None;
351 none_in_thread_have_keyword = None;
352 has_keyword = None;
353 not_keyword = None;
354 has_attachment = None;
355 text = text_filter;
356 from = None;
357 to_ = None;
358 cc = None;
359 bcc = None;
360 subject = None;
361 body = None;
362 header = None;
363 } in
364
365 let request2, email_handle =
366 let open Jmap.Chain in
367 build ~capabilities begin
368 let* query = email_query ~account_id
369 ~filter:(Jmap.Proto.Filter.Condition filter_condition)
370 ~sort:[Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"]
371 ~limit:20L
372 ()
373 in
374 email_get ~account_id
375 ~ids:(from_query query)
376 ~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
377 "size"; "receivedAt"; "from"; "subject"; "preview";
378 "hasAttachment"]
379 ()
380 end
381 in
382
383 Log.info "Sending email query request...";
384 let* response2 = Jmap_brr.request conn request2 in
385 Log.info "Got email query response";
386 match response2 with
387 | Error e ->
388 Log.error (Printf.sprintf "Failed to query emails: %s"
389 (Jstr.to_string (Jv.Error.message e)));
390 Fut.return ()
391 | Ok resp2 ->
392 Log.info "Parsing email response...";
393 match Jmap.Chain.parse email_handle resp2 with
394 | Error e ->
395 Log.error (Printf.sprintf "Failed to parse emails: %s"
396 (Jsont.Error.to_string e));
397 Fut.return ()
398 | Ok email_resp ->
399 let emails = email_resp.list in
400 Log.success (Printf.sprintf "Loaded %d emails" (List.length emails));
401 (try
402 display_emails emails
403 with exn ->
404 Log.error (Printf.sprintf "Display error: %s" (Printexc.to_string exn)));
405 Fut.return ()
406
407(* ---- Connection ---- *)
408
409let connect () =
410 let session_url = get_input_value "session-url" in
411 let api_token = get_input_value "api-token" in
412
413 if String.length api_token = 0 then begin
414 Log.error "Please enter an API token";
415 Fut.return ()
416 end else begin
417 Log.info (Printf.sprintf "Connecting to %s..." session_url);
418 set_button_loading "connect-btn" true;
419
420 let* result = Jmap_brr.get_session
421 ~url:(Jstr.v session_url)
422 ~token:(Jstr.v api_token)
423 in
424
425 set_button_loading "connect-btn" false;
426
427 match result with
428 | Error e ->
429 let msg = Jstr.to_string (Jv.Error.message e) in
430 Log.error (Printf.sprintf "Connection failed: %s" msg);
431 Fut.return ()
432 | Ok conn ->
433 let session = Jmap_brr.session conn in
434 let username = Jmap.Proto.Session.username session in
435 let api_url = Jmap.Proto.Session.api_url session in
436
437 Log.success (Printf.sprintf "Connected as %s" username);
438
439 (* Find primary mail account *)
440 let account_id =
441 match Jmap.Proto.Session.primary_account_for
442 Jmap.Capability.mail_uri session with
443 | Some id -> id
444 | None ->
445 match Jmap.Proto.Session.accounts session with
446 | (id, _) :: _ -> id
447 | [] -> failwith "No accounts found"
448 in
449
450 state.connection <- Some conn;
451 state.account_id <- Some account_id;
452
453 (* Update UI *)
454 set_text "session-username" username;
455 set_text "session-api-url" api_url;
456 set_text "session-account-id" (Jmap.Proto.Id.to_string account_id);
457 show_el "session-info";
458
459 (* Show disconnect button *)
460 let connect_btn = get_el "connect-btn" in
461 let disconnect_btn = get_el "disconnect-btn" in
462 El.set_inline_style (Jstr.v "display") (Jstr.v "none") connect_btn;
463 El.set_inline_style (Jstr.v "display") (Jstr.v "block") disconnect_btn;
464
465 (* Fetch emails *)
466 fetch_emails conn account_id
467 end
468
469let disconnect () =
470 state.connection <- None;
471 state.account_id <- None;
472
473 hide_el "session-info";
474 hide_el "email-list";
475
476 (* Reset buttons *)
477 let connect_btn = get_el "connect-btn" in
478 let disconnect_btn = get_el "disconnect-btn" in
479 El.set_inline_style (Jstr.v "display") (Jstr.v "block") connect_btn;
480 El.set_inline_style (Jstr.v "display") (Jstr.v "none") disconnect_btn;
481
482 Log.info "Disconnected"
483
484let search_emails () =
485 match state.connection, state.account_id with
486 | Some conn, Some account_id ->
487 let search_text = get_input_value "email-search" in
488 ignore (fetch_emails ~search_text conn account_id)
489 | _ ->
490 Log.warning "Not connected"
491
492(* ---- Main ---- *)
493
494let setup_handlers () =
495 let connect_btn = get_el "connect-btn" in
496 let disconnect_btn = get_el "disconnect-btn" in
497
498 (* Connect button click *)
499 ignore @@ Ev.listen Ev.click (fun _ev ->
500 ignore (connect ())
501 ) (El.as_target connect_btn);
502
503 (* Disconnect button click *)
504 ignore @@ Ev.listen Ev.click (fun _ev ->
505 disconnect ()
506 ) (El.as_target disconnect_btn);
507
508 (* Enter key in token field *)
509 let token_input = get_el "api-token" in
510 ignore @@ Ev.listen Ev.keydown (fun ev ->
511 let kev = Ev.as_type ev in
512 if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then
513 ignore (connect ())
514 ) (El.as_target token_input);
515
516 (* Search button click *)
517 let search_btn = get_el "search-btn" in
518 ignore @@ Ev.listen Ev.click (fun _ev ->
519 search_emails ()
520 ) (El.as_target search_btn);
521
522 (* Enter key in search field *)
523 let search_input = get_el "email-search" in
524 ignore @@ Ev.listen Ev.keydown (fun ev ->
525 let kev = Ev.as_type ev in
526 if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then
527 search_emails ()
528 ) (El.as_target search_input)
529
530let main () =
531 (* Register JSON loggers *)
532 Jmap_brr.set_request_logger JsonLog.request;
533 Jmap_brr.set_response_logger JsonLog.response;
534
535 Log.info "JMAP Email Client initialized";
536 Log.info "Enter your JMAP server URL and API token to connect";
537 setup_handlers ()
538
539let () = main ()