this repo has no description
anil.recoil.org
1(**
2 * JMAP protocol implementation based on RFC8620
3 * https://datatracker.ietf.org/doc/html/rfc8620
4 *)
5
6(** Whether to redact sensitive information *)
7let should_redact_sensitive = ref true
8
9(** Initialize and configure logging for JMAP *)
10let init_logging ?(level=2) ?(enable_logs=true) ?(redact_sensitive=true) () =
11 if enable_logs then begin
12 Logs.set_reporter (Logs.format_reporter ());
13 match level with
14 | 0 -> Logs.set_level None
15 | 1 -> Logs.set_level (Some Logs.Error)
16 | 2 -> Logs.set_level (Some Logs.Info)
17 | 3 -> Logs.set_level (Some Logs.Debug)
18 | _ -> Logs.set_level (Some Logs.Debug)
19 end else
20 Logs.set_level None;
21 should_redact_sensitive := redact_sensitive
22
23(** Redact sensitive data like tokens *)
24let redact_token ?(redact=true) token =
25 if redact && !should_redact_sensitive && String.length token > 8 then
26 let prefix = String.sub token 0 4 in
27 let suffix = String.sub token (String.length token - 4) 4 in
28 prefix ^ "..." ^ suffix
29 else
30 token
31
32(** Redact sensitive headers like Authorization *)
33let redact_headers headers =
34 List.map (fun (k, v) ->
35 if String.lowercase_ascii k = "authorization" then
36 if !should_redact_sensitive then
37 let parts = String.split_on_char ' ' v in
38 match parts with
39 | scheme :: token :: _ -> (k, scheme ^ " " ^ redact_token token)
40 | _ -> (k, v)
41 else (k, v)
42 else (k, v)
43 ) headers
44
45(* Initialize logging with defaults *)
46let () = init_logging ()
47
48(** Module for managing JMAP capability URIs and other constants *)
49module Capability = struct
50 (** JMAP capability URI as specified in RFC8620 *)
51 let core_uri = "urn:ietf:params:jmap:core"
52
53 (** All JMAP capability types *)
54 type t =
55 | Core (** Core JMAP capability *)
56 | Extension of string (** Extension capabilities *)
57
58 (** Convert capability to URI string *)
59 let to_string = function
60 | Core -> core_uri
61 | Extension s -> s
62
63 (** Parse a string to a capability, returns Extension for non-core capabilities *)
64 let of_string s =
65 if s = core_uri then Core
66 else Extension s
67
68 (** Check if a capability matches a core capability *)
69 let is_core = function
70 | Core -> true
71 | Extension _ -> false
72
73 (** Check if a capability string is a core capability *)
74 let is_core_string s = s = core_uri
75
76 (** Create a list of capability strings *)
77 let strings_of_capabilities capabilities =
78 List.map to_string capabilities
79end
80
81module Types = struct
82 (** Id string as per Section 1.2 *)
83 type id = string
84
85 (** Int bounded within the range -2^53+1 to 2^53-1 as per Section 1.3 *)
86 type int_t = int
87
88 (** UnsignedInt bounded within the range 0 to 2^53-1 as per Section 1.3 *)
89 type unsigned_int = int
90
91 (** Date string in RFC3339 format as per Section 1.4 *)
92 type date = string
93
94 (** UTCDate is a Date with 'Z' time zone as per Section 1.4 *)
95 type utc_date = string
96
97 (** Error object as per Section 3.6.2 *)
98 type error = {
99 type_: string;
100 description: string option;
101 }
102
103 (** Set error object as per Section 5.3 *)
104 type set_error = {
105 type_: string;
106 description: string option;
107 properties: string list option;
108 (* Additional properties for specific error types *)
109 existing_id: id option; (* For alreadyExists error *)
110 }
111
112 (** Invocation object as per Section 3.2 *)
113 type 'a invocation = {
114 name: string;
115 arguments: 'a;
116 method_call_id: string;
117 }
118
119 (** ResultReference object as per Section 3.7 *)
120 type result_reference = {
121 result_of: string;
122 name: string;
123 path: string;
124 }
125
126 (** FilterOperator, FilterCondition and Filter as per Section 5.5 *)
127 type filter_operator = {
128 operator: string; (* "AND", "OR", "NOT" *)
129 conditions: filter list;
130 }
131 and filter_condition = (string * Ezjsonm.value) list
132 and filter =
133 | Operator of filter_operator
134 | Condition of filter_condition
135
136 (** Comparator object for sorting as per Section 5.5 *)
137 type comparator = {
138 property: string;
139 is_ascending: bool option; (* Optional, defaults to true *)
140 collation: string option; (* Optional, server-dependent default *)
141 }
142
143 (** PatchObject as per Section 5.3 *)
144 type patch_object = (string * Ezjsonm.value) list
145
146 (** AddedItem structure as per Section 5.6 *)
147 type added_item = {
148 id: id;
149 index: unsigned_int;
150 }
151
152 (** Account object as per Section 1.6.2 *)
153 type account = {
154 name: string;
155 is_personal: bool;
156 is_read_only: bool;
157 account_capabilities: (string * Ezjsonm.value) list;
158 }
159
160 (** Core capability object as per Section 2 *)
161 type core_capability = {
162 max_size_upload: unsigned_int;
163 max_concurrent_upload: unsigned_int;
164 max_size_request: unsigned_int;
165 max_concurrent_requests: unsigned_int;
166 max_calls_in_request: unsigned_int;
167 max_objects_in_get: unsigned_int;
168 max_objects_in_set: unsigned_int;
169 collation_algorithms: string list;
170 }
171
172 (** PushSubscription keys object as per Section 7.2 *)
173 type push_keys = {
174 p256dh: string;
175 auth: string;
176 }
177
178 (** Session object as per Section 2 *)
179 type session = {
180 capabilities: (string * Ezjsonm.value) list;
181 accounts: (id * account) list;
182 primary_accounts: (string * id) list;
183 username: string;
184 api_url: string;
185 download_url: string;
186 upload_url: string;
187 event_source_url: string option;
188 state: string;
189 }
190
191 (** TypeState for state changes as per Section 7.1 *)
192 type type_state = (string * string) list
193
194 (** StateChange object as per Section 7.1 *)
195 type state_change = {
196 changed: (id * type_state) list;
197 }
198
199 (** PushVerification object as per Section 7.2.2 *)
200 type push_verification = {
201 push_subscription_id: id;
202 verification_code: string;
203 }
204
205 (** PushSubscription object as per Section 7.2 *)
206 type push_subscription = {
207 id: id;
208 device_client_id: string;
209 url: string;
210 keys: push_keys option;
211 verification_code: string option;
212 expires: utc_date option;
213 types: string list option;
214 }
215
216 (** Request object as per Section 3.3 *)
217 type request = {
218 using: string list;
219 method_calls: Ezjsonm.value invocation list;
220 created_ids: (id * id) list option;
221 }
222
223 (** Response object as per Section 3.4 *)
224 type response = {
225 method_responses: Ezjsonm.value invocation list;
226 created_ids: (id * id) list option;
227 session_state: string;
228 }
229
230 (** Standard method arguments and responses *)
231
232 (** Arguments for Foo/get method as per Section 5.1 *)
233 type 'a get_arguments = {
234 account_id: id;
235 ids: id list option;
236 properties: string list option;
237 }
238
239 (** Response for Foo/get method as per Section 5.1 *)
240 type 'a get_response = {
241 account_id: id;
242 state: string;
243 list: 'a list;
244 not_found: id list;
245 }
246
247 (** Arguments for Foo/changes method as per Section 5.2 *)
248 type changes_arguments = {
249 account_id: id;
250 since_state: string;
251 max_changes: unsigned_int option;
252 }
253
254 (** Response for Foo/changes method as per Section 5.2 *)
255 type changes_response = {
256 account_id: id;
257 old_state: string;
258 new_state: string;
259 has_more_changes: bool;
260 created: id list;
261 updated: id list;
262 destroyed: id list;
263 }
264
265 (** Arguments for Foo/set method as per Section 5.3 *)
266 type 'a set_arguments = {
267 account_id: id;
268 if_in_state: string option;
269 create: (id * 'a) list option;
270 update: (id * patch_object) list option;
271 destroy: id list option;
272 }
273
274 (** Response for Foo/set method as per Section 5.3 *)
275 type 'a set_response = {
276 account_id: id;
277 old_state: string option;
278 new_state: string;
279 created: (id * 'a) list option;
280 updated: (id * 'a option) list option;
281 destroyed: id list option;
282 not_created: (id * set_error) list option;
283 not_updated: (id * set_error) list option;
284 not_destroyed: (id * set_error) list option;
285 }
286
287 (** Arguments for Foo/copy method as per Section 5.4 *)
288 type 'a copy_arguments = {
289 from_account_id: id;
290 if_from_in_state: string option;
291 account_id: id;
292 if_in_state: string option;
293 create: (id * 'a) list;
294 on_success_destroy_original: bool option;
295 destroy_from_if_in_state: string option;
296 }
297
298 (** Response for Foo/copy method as per Section 5.4 *)
299 type 'a copy_response = {
300 from_account_id: id;
301 account_id: id;
302 old_state: string option;
303 new_state: string;
304 created: (id * 'a) list option;
305 not_created: (id * set_error) list option;
306 }
307
308 (** Arguments for Foo/query method as per Section 5.5 *)
309 type query_arguments = {
310 account_id: id;
311 filter: filter option;
312 sort: comparator list option;
313 position: int_t option;
314 anchor: id option;
315 anchor_offset: int_t option;
316 limit: unsigned_int option;
317 calculate_total: bool option;
318 }
319
320 (** Response for Foo/query method as per Section 5.5 *)
321 type query_response = {
322 account_id: id;
323 query_state: string;
324 can_calculate_changes: bool;
325 position: unsigned_int;
326 ids: id list;
327 total: unsigned_int option;
328 limit: unsigned_int option;
329 }
330
331 (** Arguments for Foo/queryChanges method as per Section 5.6 *)
332 type query_changes_arguments = {
333 account_id: id;
334 filter: filter option;
335 sort: comparator list option;
336 since_query_state: string;
337 max_changes: unsigned_int option;
338 up_to_id: id option;
339 calculate_total: bool option;
340 }
341
342 (** Response for Foo/queryChanges method as per Section 5.6 *)
343 type query_changes_response = {
344 account_id: id;
345 old_query_state: string;
346 new_query_state: string;
347 total: unsigned_int option;
348 removed: id list;
349 added: added_item list option;
350 }
351
352 (** Arguments for Blob/copy method as per Section 6.3 *)
353 type blob_copy_arguments = {
354 from_account_id: id;
355 account_id: id;
356 blob_ids: id list;
357 }
358
359 (** Response for Blob/copy method as per Section 6.3 *)
360 type blob_copy_response = {
361 from_account_id: id;
362 account_id: id;
363 copied: (id * id) list option;
364 not_copied: (id * set_error) list option;
365 }
366
367 (** Upload response as per Section 6.1 *)
368 type upload_response = {
369 account_id: id;
370 blob_id: id;
371 type_: string;
372 size: unsigned_int;
373 }
374
375 (** Problem details object as per RFC7807 and Section 3.6.1 *)
376 type problem_details = {
377 type_: string;
378 status: int option;
379 detail: string option;
380 limit: string option; (* For "limit" error *)
381 }
382end
383
384(** Module for working with ResultReferences as described in Section 3.7 of RFC8620 *)
385module ResultReference = struct
386 open Types
387
388 (** Create a reference to a previous method result *)
389 let create ~result_of ~name ~path =
390 { result_of; name; path }
391
392 (** Create a JSON pointer path to access a specific property *)
393 let property_path property =
394 "/" ^ property
395
396 (** Create a JSON pointer path to access all items in an array with a specific property *)
397 let array_items_path ?(property="") array_property =
398 let base = "/" ^ array_property ^ "/*" in
399 if property = "" then base
400 else base ^ "/" ^ property
401
402 (** Create argument with result reference.
403 Returns string key prefixed with # and ResultReference value. *)
404 let reference_arg arg_name ref_obj =
405 (* Prefix argument name with # *)
406 let prefixed_name = "#" ^ arg_name in
407
408 (* Convert reference object to JSON *)
409 let json_value = `O [
410 ("resultOf", `String ref_obj.result_of);
411 ("name", `String ref_obj.name);
412 ("path", `String ref_obj.path)
413 ] in
414
415 (prefixed_name, json_value)
416
417 (** Create a reference to all IDs returned by a query method *)
418 let query_ids ~result_of =
419 create
420 ~result_of
421 ~name:"Foo/query"
422 ~path:"/ids"
423
424 (** Create a reference to properties of objects returned by a get method *)
425 let get_property ~result_of ~property =
426 create
427 ~result_of
428 ~name:"Foo/get"
429 ~path:("/list/*/" ^ property)
430end
431
432module Api = struct
433 open Lwt.Syntax
434 open Types
435
436 (** Error that may occur during API requests *)
437 type error =
438 | Connection_error of string
439 | HTTP_error of int * string
440 | Parse_error of string
441 | Authentication_error
442
443 (** Result type for API operations *)
444 type 'a result = ('a, error) Stdlib.result
445
446 (** Convert an error to a human-readable string *)
447 let string_of_error = function
448 | Connection_error msg -> "Connection error: " ^ msg
449 | HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
450 | Parse_error msg -> "Parse error: " ^ msg
451 | Authentication_error -> "Authentication error"
452
453 (** Pretty-print an error to a formatter *)
454 let pp_error ppf err =
455 Format.fprintf ppf "%s" (string_of_error err)
456
457 (** Configuration for a JMAP API client *)
458 type config = {
459 api_uri: Uri.t;
460 username: string;
461 authentication_token: string;
462 }
463
464 (** Convert Ezjsonm.value to string *)
465 let json_to_string json =
466 Ezjsonm.value_to_string ~minify:false json
467
468 (** Parse response string as JSON value *)
469 let parse_json_string str =
470 try Ok (Ezjsonm.from_string str)
471 with e -> Error (Parse_error (Printexc.to_string e))
472
473 (** Parse JSON response as a JMAP response object *)
474 let parse_response json =
475 try
476 let method_responses =
477 match Ezjsonm.find json ["methodResponses"] with
478 | `A items ->
479 List.map (fun json ->
480 match json with
481 | `A [`String name; args; `String method_call_id] ->
482 { name; arguments = args; method_call_id }
483 | _ -> raise (Invalid_argument "Invalid invocation format in response")
484 ) items
485 | _ -> raise (Invalid_argument "methodResponses is not an array")
486 in
487 let created_ids_opt =
488 try
489 let obj = Ezjsonm.find json ["createdIds"] in
490 match obj with
491 | `O items -> Some (List.map (fun (k, v) ->
492 match v with
493 | `String id -> (k, id)
494 | _ -> raise (Invalid_argument "createdIds value is not a string")
495 ) items)
496 | _ -> None
497 with Not_found -> None
498 in
499 let session_state =
500 match Ezjsonm.find json ["sessionState"] with
501 | `String s -> s
502 | _ -> raise (Invalid_argument "sessionState is not a string")
503 in
504 Ok { method_responses; created_ids = created_ids_opt; session_state }
505 with
506 | Not_found -> Error (Parse_error "Required field not found in response")
507 | Invalid_argument msg -> Error (Parse_error msg)
508 | e -> Error (Parse_error (Printexc.to_string e))
509
510 (** Serialize a JMAP request object to JSON *)
511 let serialize_request req =
512 let method_calls_json =
513 `A (List.map (fun (inv : 'a invocation) ->
514 `A [`String inv.name; inv.arguments; `String inv.method_call_id]
515 ) req.method_calls)
516 in
517 let using_json = `A (List.map (fun s -> `String s) req.using) in
518 let json = `O [
519 ("using", using_json);
520 ("methodCalls", method_calls_json)
521 ] in
522 let json = match req.created_ids with
523 | Some ids ->
524 let created_ids_json = `O (List.map (fun (k, v) -> (k, `String v)) ids) in
525 Ezjsonm.update json ["createdIds"] (Some created_ids_json)
526 | None -> json
527 in
528 json_to_string json
529
530 (** Make a raw HTTP request *)
531 let make_http_request ~method_ ~headers ~body uri =
532 let open Cohttp in
533 let open Cohttp_lwt_unix in
534 let headers = Header.add_list (Header.init ()) headers in
535
536 (* Print detailed request information to stderr for debugging *)
537 let header_list = Cohttp.Header.to_list headers in
538 let redacted_headers = redact_headers header_list in
539 Logs.info (fun m ->
540 m "\n===== HTTP REQUEST =====\n\
541 URI: %s\n\
542 METHOD: %s\n\
543 HEADERS:\n%s\n\
544 BODY:\n%s\n\
545 ======================\n"
546 (Uri.to_string uri)
547 method_
548 (String.concat "\n" (List.map (fun (k, v) -> Printf.sprintf " %s: %s" k v) redacted_headers))
549 body);
550
551 (* Force printing to stderr for immediate debugging *)
552 Printf.eprintf "[DEBUG-REQUEST] URI: %s\n" (Uri.to_string uri);
553 Printf.eprintf "[DEBUG-REQUEST] METHOD: %s\n" method_;
554 Printf.eprintf "[DEBUG-REQUEST] BODY: %s\n%!" body;
555
556 Lwt.catch
557 (fun () ->
558 let* resp, body =
559 match method_ with
560 | "GET" -> Client.get ~headers uri
561 | "POST" -> Client.post ~headers ~body:(Cohttp_lwt.Body.of_string body) uri
562 | _ -> failwith (Printf.sprintf "Unsupported HTTP method: %s" method_)
563 in
564 let* body_str = Cohttp_lwt.Body.to_string body in
565 let status = Response.status resp |> Code.code_of_status in
566
567 (* Print detailed response information to stderr for debugging *)
568 let header_list = Cohttp.Header.to_list (Response.headers resp) in
569 let redacted_headers = redact_headers header_list in
570 Logs.info (fun m ->
571 m "\n===== HTTP RESPONSE =====\n\
572 STATUS: %d\n\
573 HEADERS:\n%s\n\
574 BODY:\n%s\n\
575 ======================\n"
576 status
577 (String.concat "\n" (List.map (fun (k, v) -> Printf.sprintf " %s: %s" k v) redacted_headers))
578 body_str);
579
580 (* Force printing to stderr for immediate debugging *)
581 Printf.eprintf "[DEBUG-RESPONSE] STATUS: %d\n" status;
582 Printf.eprintf "[DEBUG-RESPONSE] BODY: %s\n%!" body_str;
583
584 if status >= 200 && status < 300 then
585 Lwt.return (Ok body_str)
586 else
587 Lwt.return (Error (HTTP_error (status, body_str))))
588 (fun e ->
589 let error_msg = Printexc.to_string e in
590 Printf.eprintf "[DEBUG-ERROR] %s\n%!" error_msg;
591 Logs.err (fun m -> m "%s" error_msg);
592 Lwt.return (Error (Connection_error error_msg)))
593
594 (** Make a raw JMAP API request
595
596 TODO:claude *)
597 let make_request config req =
598 let body = serialize_request req in
599 (* Choose appropriate authorization header based on whether it's a bearer token or basic auth *)
600 let auth_header =
601 if String.length config.username > 0 then
602 (* Standard username/password authentication *)
603 "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token)
604 else
605 (* API token (bearer authentication) *)
606 "Bearer " ^ config.authentication_token
607 in
608
609 (* Log auth header at debug level with redaction *)
610 let redacted_header =
611 if String.length config.username > 0 then
612 "Basic " ^ redact_token (Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
613 else
614 "Bearer " ^ redact_token config.authentication_token
615 in
616 Logs.debug (fun m -> m "Using authorization header: %s" redacted_header);
617
618 let headers = [
619 ("Content-Type", "application/json");
620 ("Content-Length", string_of_int (String.length body));
621 ("Authorization", auth_header)
622 ] in
623 let* result = make_http_request ~method_:"POST" ~headers ~body config.api_uri in
624 match result with
625 | Ok response_body ->
626 (match parse_json_string response_body with
627 | Ok json ->
628 Logs.debug (fun m -> m "Successfully parsed JSON response");
629 Lwt.return (parse_response json)
630 | Error e ->
631 let msg = match e with Parse_error m -> m | _ -> "unknown error" in
632 Logs.err (fun m -> m "Failed to parse response: %s" msg);
633 Lwt.return (Error e))
634 | Error e ->
635 (match e with
636 | Connection_error msg -> Logs.err (fun m -> m "Connection error: %s" msg)
637 | HTTP_error (code, _) -> Logs.err (fun m -> m "HTTP error %d" code)
638 | Parse_error msg -> Logs.err (fun m -> m "Parse error: %s" msg)
639 | Authentication_error -> Logs.err (fun m -> m "Authentication error"));
640 Lwt.return (Error e)
641
642 (** Parse a JSON object as a Session object *)
643 let parse_session_object json =
644 try
645 let capabilities =
646 match Ezjsonm.find json ["capabilities"] with
647 | `O items -> items
648 | _ -> raise (Invalid_argument "capabilities is not an object")
649 in
650
651 let accounts =
652 match Ezjsonm.find json ["accounts"] with
653 | `O items -> List.map (fun (id, json) ->
654 match json with
655 | `O _ ->
656 let name = Ezjsonm.get_string (Ezjsonm.find json ["name"]) in
657 let is_personal = Ezjsonm.get_bool (Ezjsonm.find json ["isPersonal"]) in
658 let is_read_only = Ezjsonm.get_bool (Ezjsonm.find json ["isReadOnly"]) in
659 let account_capabilities =
660 match Ezjsonm.find json ["accountCapabilities"] with
661 | `O items -> items
662 | _ -> raise (Invalid_argument "accountCapabilities is not an object")
663 in
664 (id, { name; is_personal; is_read_only; account_capabilities })
665 | _ -> raise (Invalid_argument "account value is not an object")
666 ) items
667 | _ -> raise (Invalid_argument "accounts is not an object")
668 in
669
670 let primary_accounts =
671 match Ezjsonm.find_opt json ["primaryAccounts"] with
672 | Some (`O items) -> List.map (fun (k, v) ->
673 match v with
674 | `String id -> (k, id)
675 | _ -> raise (Invalid_argument "primaryAccounts value is not a string")
676 ) items
677 | Some _ -> raise (Invalid_argument "primaryAccounts is not an object")
678 | None -> []
679 in
680
681 let username = Ezjsonm.get_string (Ezjsonm.find json ["username"]) in
682 let api_url = Ezjsonm.get_string (Ezjsonm.find json ["apiUrl"]) in
683 let download_url = Ezjsonm.get_string (Ezjsonm.find json ["downloadUrl"]) in
684 let upload_url = Ezjsonm.get_string (Ezjsonm.find json ["uploadUrl"]) in
685 let event_source_url =
686 try Some (Ezjsonm.get_string (Ezjsonm.find json ["eventSourceUrl"]))
687 with Not_found -> None
688 in
689 let state = Ezjsonm.get_string (Ezjsonm.find json ["state"]) in
690
691 Ok { capabilities; accounts; primary_accounts; username;
692 api_url; download_url; upload_url; event_source_url; state }
693 with
694 | Not_found -> Error (Parse_error "Required field not found in session object")
695 | Invalid_argument msg -> Error (Parse_error msg)
696 | e -> Error (Parse_error (Printexc.to_string e))
697
698 (** Fetch a Session object from a JMAP server
699
700 TODO:claude *)
701 let get_session uri ?username ?authentication_token ?api_token () =
702 let headers =
703 match (username, authentication_token, api_token) with
704 | (Some u, Some t, _) ->
705 let auth = "Basic " ^ Base64.encode_string (u ^ ":" ^ t) in
706 let redacted_auth = "Basic " ^ redact_token (Base64.encode_string (u ^ ":" ^ t)) in
707 Logs.info (fun m -> m "Session using Basic auth: %s" redacted_auth);
708 [
709 ("Content-Type", "application/json");
710 ("Authorization", auth)
711 ]
712 | (_, _, Some token) ->
713 let auth = "Bearer " ^ token in
714 let redacted_token = redact_token token in
715 Logs.info (fun m -> m "Session using Bearer auth: %s" ("Bearer " ^ redacted_token));
716 [
717 ("Content-Type", "application/json");
718 ("Authorization", auth)
719 ]
720 | _ -> [("Content-Type", "application/json")]
721 in
722
723 let* result = make_http_request ~method_:"GET" ~headers ~body:"" uri in
724 match result with
725 | Ok response_body ->
726 (match parse_json_string response_body with
727 | Ok json ->
728 Logs.debug (fun m -> m "Successfully parsed session response");
729 Lwt.return (parse_session_object json)
730 | Error e ->
731 let msg = match e with Parse_error m -> m | _ -> "unknown error" in
732 Logs.err (fun m -> m "Failed to parse session response: %s" msg);
733 Lwt.return (Error e))
734 | Error e ->
735 let err_msg = match e with
736 | Connection_error msg -> "Connection error: " ^ msg
737 | HTTP_error (code, _) -> Printf.sprintf "HTTP error %d" code
738 | Parse_error msg -> "Parse error: " ^ msg
739 | Authentication_error -> "Authentication error"
740 in
741 Logs.err (fun m -> m "Failed to get session: %s" err_msg);
742 Lwt.return (Error e)
743
744 (** Upload a binary blob to the server
745
746 TODO:claude *)
747 let upload_blob config ~account_id ~content_type data =
748 let upload_url_template = config.api_uri |> Uri.to_string in
749 (* Replace {accountId} with the actual account ID *)
750 let upload_url = Str.global_replace (Str.regexp "{accountId}") account_id upload_url_template in
751 let upload_uri = Uri.of_string upload_url in
752
753 let headers = [
754 ("Content-Type", content_type);
755 ("Content-Length", string_of_int (String.length data));
756 ("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
757 ] in
758
759 let* result = make_http_request ~method_:"POST" ~headers ~body:data upload_uri in
760 match result with
761 | Ok response_body ->
762 (match parse_json_string response_body with
763 | Ok json ->
764 (try
765 let account_id = Ezjsonm.get_string (Ezjsonm.find json ["accountId"]) in
766 let blob_id = Ezjsonm.get_string (Ezjsonm.find json ["blobId"]) in
767 let type_ = Ezjsonm.get_string (Ezjsonm.find json ["type"]) in
768 let size = Ezjsonm.get_int (Ezjsonm.find json ["size"]) in
769 Lwt.return (Ok { account_id; blob_id; type_; size })
770 with
771 | Not_found -> Lwt.return (Error (Parse_error "Required field not found in upload response"))
772 | e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
773 | Error e -> Lwt.return (Error e))
774 | Error e -> Lwt.return (Error e)
775
776 (** Download a binary blob from the server
777
778 TODO:claude *)
779 let download_blob config ~account_id ~blob_id ?type_ ?name () =
780 let download_url_template = config.api_uri |> Uri.to_string in
781
782 (* Replace template variables with actual values *)
783 let url = Str.global_replace (Str.regexp "{accountId}") account_id download_url_template in
784 let url = Str.global_replace (Str.regexp "{blobId}") blob_id url in
785
786 let url = match type_ with
787 | Some t -> Str.global_replace (Str.regexp "{type}") (Uri.pct_encode t) url
788 | None -> Str.global_replace (Str.regexp "{type}") "" url
789 in
790
791 let url = match name with
792 | Some n -> Str.global_replace (Str.regexp "{name}") (Uri.pct_encode n) url
793 | None -> Str.global_replace (Str.regexp "{name}") "file" url
794 in
795
796 let download_uri = Uri.of_string url in
797
798 let headers = [
799 ("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
800 ] in
801
802 let* result = make_http_request ~method_:"GET" ~headers ~body:"" download_uri in
803 Lwt.return result
804end