this repo has no description
jsont
+2778
-3855
+1
stack/.gitignore
+1
stack/.gitignore
···
1
+
_build
+2
-1
stack/cacheio/cacheio.opam
+2
-1
stack/cacheio/cacheio.opam
+2
-1
stack/cacheio/dune-project
+2
-1
stack/cacheio/dune-project
+1
-1
stack/cacheio/lib/dune
+1
-1
stack/cacheio/lib/dune
···
2
2
(public_name cacheio)
3
3
(name cacheio)
4
4
(modules cacheio flags entry stats range chunk)
5
-
(libraries eio eio_main digestif yojson ptime ptime.clock.os logs fmt xdge cstruct))
5
+
(libraries eio eio_main digestif jsont jsont.bytesrw ptime ptime.clock.os logs fmt xdge cstruct))
6
6
7
7
(library
8
8
(public_name cacheio.cmd)
+23
-1
stack/cacheio/lib/entry.ml
+23
-1
stack/cacheio/lib/entry.ml
···
45
45
(match t.ttl with
46
46
| None -> "never"
47
47
| Some exp -> Printf.sprintf "%.1f" exp)
48
-
Flags.pp t.flags
48
+
Flags.pp t.flags
49
+
50
+
(* Jsont support *)
51
+
52
+
(* Helper codec for int64 *)
53
+
let int64_jsont =
54
+
let kind = "Int64" in
55
+
let doc = "64-bit integer as number" in
56
+
let dec n = Int64.of_float n in
57
+
let enc i = Int64.to_float i in
58
+
Jsont.map ~kind ~doc ~dec ~enc Jsont.number
59
+
60
+
let jsont =
61
+
let kind = "Entry" in
62
+
let doc = "A cache entry" in
63
+
let make key size mtime ttl flags = { key; size; mtime; ttl; flags } in
64
+
Jsont.Object.map ~kind ~doc make
65
+
|> Jsont.Object.mem "key" Jsont.string ~enc:key
66
+
|> Jsont.Object.mem "size" int64_jsont ~enc:size
67
+
|> Jsont.Object.mem "mtime" Jsont.number ~enc:mtime
68
+
|> Jsont.Object.opt_mem "ttl" Jsont.number ~enc:ttl
69
+
|> Jsont.Object.mem "flags" Flags.jsont ~enc:flags
70
+
|> Jsont.Object.finish
+6
-1
stack/cacheio/lib/entry.mli
+6
-1
stack/cacheio/lib/entry.mli
+31
-1
stack/cacheio/lib/flags.ml
+31
-1
stack/cacheio/lib/flags.ml
···
97
97
| `Pinned -> "P"
98
98
| `Stale -> "S"
99
99
| `Temporary -> "T"
100
-
| `Chunk -> "C") flags))
100
+
| `Chunk -> "C") flags))
101
+
102
+
(* Jsont support *)
103
+
104
+
(* JSON codec for individual flags - using string representation *)
105
+
let flag_jsont =
106
+
let kind = "Flag" in
107
+
let doc = "A cache entry flag" in
108
+
let dec s =
109
+
match s with
110
+
| "pinned" -> `Pinned
111
+
| "stale" -> `Stale
112
+
| "temporary" -> `Temporary
113
+
| "chunk" -> `Chunk
114
+
| _ -> Jsont.Error.msg Jsont.Meta.none "Invalid flag value"
115
+
in
116
+
let enc = function
117
+
| `Pinned -> "pinned"
118
+
| `Stale -> "stale"
119
+
| `Temporary -> "temporary"
120
+
| `Chunk -> "chunk"
121
+
in
122
+
Jsont.map ~kind ~doc ~dec ~enc Jsont.string
123
+
124
+
(* JSON codec for flag set *)
125
+
let jsont =
126
+
let kind = "Flags" in
127
+
let doc = "A set of cache entry flags" in
128
+
let dec lst = of_list lst in
129
+
let enc t = to_list t in
130
+
Jsont.map ~kind ~doc ~dec ~enc (Jsont.list flag_jsont)
+6
-1
stack/cacheio/lib/flags.mli
+6
-1
stack/cacheio/lib/flags.mli
+26
-1
stack/cacheio/lib/stats.ml
+26
-1
stack/cacheio/lib/stats.ml
···
48
48
t.expired_count
49
49
t.pinned_count
50
50
t.stale_count
51
-
t.temporary_count
51
+
t.temporary_count
52
+
53
+
(* Jsont support *)
54
+
55
+
(* Helper codec for int64 *)
56
+
let int64_jsont =
57
+
let kind = "Int64" in
58
+
let doc = "64-bit integer as number" in
59
+
let dec n = Int64.of_float n in
60
+
let enc i = Int64.to_float i in
61
+
Jsont.map ~kind ~doc ~dec ~enc Jsont.number
62
+
63
+
let jsont =
64
+
let kind = "Stats" in
65
+
let doc = "Cache statistics" in
66
+
let make total_size entry_count expired_count pinned_count stale_count temporary_count =
67
+
{ total_size; entry_count; expired_count; pinned_count; stale_count; temporary_count }
68
+
in
69
+
Jsont.Object.map ~kind ~doc make
70
+
|> Jsont.Object.mem "total_size" int64_jsont ~enc:total_size
71
+
|> Jsont.Object.mem "entry_count" Jsont.int ~enc:entry_count
72
+
|> Jsont.Object.mem "expired_count" Jsont.int ~enc:expired_count
73
+
|> Jsont.Object.mem "pinned_count" Jsont.int ~enc:pinned_count
74
+
|> Jsont.Object.mem "stale_count" Jsont.int ~enc:stale_count
75
+
|> Jsont.Object.mem "temporary_count" Jsont.int ~enc:temporary_count
76
+
|> Jsont.Object.finish
+6
-1
stack/cacheio/lib/stats.mli
+6
-1
stack/cacheio/lib/stats.mli
+1
-1
stack/immich/dune
+1
-1
stack/immich/dune
+2
-1
stack/immich/dune-project
+2
-1
stack/immich/dune-project
+44
-36
stack/immich/immich.ml
+44
-36
stack/immich/immich.ml
···
18
18
birth_date: string option;
19
19
thumbnail_path: string;
20
20
is_hidden: bool;
21
-
}
22
-
23
-
type people_response = {
24
-
total: int;
25
-
visible: int;
26
-
people: person list;
21
+
unknown: Jsont.json;
27
22
}
28
23
29
24
(** {1 Client Creation} *)
···
33
28
let requests_session = Requests.set_default_header requests_session "x-api-key" api_key in
34
29
{ base_url; api_key; requests_session }
35
30
36
-
(** {1 JSON Parsing} *)
31
+
(** {1 JSON Codecs} *)
37
32
38
-
(* Parse a single person from JSON *)
39
-
let parse_person json =
40
-
let open Ezjsonm in
41
-
let id = find json ["id"] |> get_string in
42
-
let name = find json ["name"] |> get_string in
43
-
let birth_date =
44
-
try Some (find json ["birthDate"] |> get_string)
45
-
with _ -> None
46
-
in
47
-
let thumbnail_path = find json ["thumbnailPath"] |> get_string in
48
-
let is_hidden =
49
-
try find json ["isHidden"] |> get_bool
50
-
with _ -> false
33
+
(* Jsont codec for person *)
34
+
let person_jsont =
35
+
let make id name birth_date thumbnail_path is_hidden unknown =
36
+
{ id; name; birth_date; thumbnail_path; is_hidden; unknown }
51
37
in
52
-
{ id; name; birth_date; thumbnail_path; is_hidden }
38
+
let id p = p.id in
39
+
let name p = p.name in
40
+
let birth_date p = p.birth_date in
41
+
let thumbnail_path p = p.thumbnail_path in
42
+
let is_hidden p = p.is_hidden in
43
+
let unknown p = p.unknown in
44
+
Jsont.Object.map ~kind:"Person" make
45
+
|> Jsont.Object.mem "id" Jsont.string ~enc:id
46
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
47
+
|> Jsont.Object.opt_mem "birthDate" Jsont.string ~enc:birth_date
48
+
|> Jsont.Object.mem "thumbnailPath" Jsont.string ~enc:thumbnail_path
49
+
|> Jsont.Object.mem "isHidden" Jsont.bool ~enc:is_hidden
50
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
51
+
|> Jsont.Object.finish
53
52
54
-
(* Parse people response from JSON *)
55
-
let parse_people_response json =
56
-
let open Ezjsonm in
57
-
let total = find json ["total"] |> get_int in
58
-
let visible = find json ["visible"] |> get_int in
59
-
let people_json = find json ["people"] in
60
-
let people = get_list parse_person people_json in
61
-
{ total; visible; people }
53
+
type people_response = {
54
+
total: int;
55
+
visible: int;
56
+
people: person list;
57
+
unknown: Jsont.json;
58
+
}
62
59
63
-
(* Parse a list of people from search results *)
64
-
let parse_person_list json =
65
-
let open Ezjsonm in
66
-
get_list parse_person json
60
+
(* Jsont codec for people_response *)
61
+
let people_response_jsont =
62
+
let make total visible people unknown =
63
+
{ total; visible; people; unknown }
64
+
in
65
+
let total r = r.total in
66
+
let visible r = r.visible in
67
+
let people r = r.people in
68
+
let unknown r = r.unknown in
69
+
Jsont.Object.map ~kind:"PeopleResponse" make
70
+
|> Jsont.Object.mem "total" Jsont.int ~enc:total
71
+
|> Jsont.Object.mem "visible" Jsont.int ~enc:visible
72
+
|> Jsont.Object.mem "people" (Jsont.list person_jsont) ~enc:people
73
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
74
+
|> Jsont.Object.finish
67
75
68
76
(** {1 API Functions} *)
69
77
70
78
let fetch_people { base_url; requests_session; _ } =
71
79
let open Requests_json_api in
72
80
let url = base_url / "api/people" in
73
-
get_json_exn requests_session url parse_people_response
81
+
get_json_exn requests_session url people_response_jsont
74
82
75
83
let fetch_person { base_url; requests_session; _ } ~person_id =
76
84
let open Requests_json_api in
77
85
let url = base_url / "api/people" / person_id in
78
-
get_json_exn requests_session url parse_person
86
+
get_json_exn requests_session url person_jsont
79
87
80
88
let download_thumbnail { base_url; requests_session; _ } ~fs ~person_id ~output_path =
81
89
try
···
104
112
let open Requests_json_api in
105
113
let encoded_name = Uri.pct_encode name in
106
114
let url = sprintf "%s/api/search/person?name=%s" base_url encoded_name in
107
-
get_json_exn requests_session url parse_person_list
115
+
get_json_exn requests_session url (Jsont.list person_jsont)
+2
stack/immich/immich.mli
+2
stack/immich/immich.mli
···
16
16
birth_date: string option;
17
17
thumbnail_path: string;
18
18
is_hidden: bool;
19
+
unknown: Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
19
20
}
20
21
21
22
(** Type for the people API response *)
···
23
24
total: int;
24
25
visible: int;
25
26
people: person list;
27
+
unknown: Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
26
28
}
27
29
28
30
(** {1 Client Creation} *)
+2
-1
stack/immich/immich.opam
+2
-1
stack/immich/immich.opam
+42
-37
stack/karakeep/bin/karakeep_cli.ml
+42
-37
stack/karakeep/bin/karakeep_cli.ml
···
27
27
let bookmarks =
28
28
List.filter (fun (b : Karakeep.bookmark) ->
29
29
(match archived with
30
-
| Some true -> b.archived
31
-
| Some false -> not b.archived
30
+
| Some true -> Karakeep.bookmark_archived b
31
+
| Some false -> not (Karakeep.bookmark_archived b)
32
32
| None -> true) &&
33
33
(match favourited with
34
-
| Some true -> b.favourited
35
-
| Some false -> not b.favourited
34
+
| Some true -> Karakeep.bookmark_favourited b
35
+
| Some false -> not (Karakeep.bookmark_favourited b)
36
36
| None -> true)
37
37
) bookmarks
38
38
in
···
40
40
Printf.printf "Found %d bookmarks\n\n" (List.length bookmarks);
41
41
42
42
List.iteri (fun i (b : Karakeep.bookmark) ->
43
-
Printf.printf "%d. %s\n" (i + 1) b.url;
44
-
(match b.title with
43
+
Printf.printf "%d. %s\n" (i + 1) (Karakeep.bookmark_url b);
44
+
(match Karakeep.bookmark_title b with
45
45
| Some title -> Printf.printf " Title: %s\n" title
46
46
| None -> ());
47
-
Printf.printf " ID: %s\n" b.id;
48
-
Printf.printf " Created: %s\n" (Ptime.to_rfc3339 b.created_at);
49
-
if b.tags <> [] then
50
-
Printf.printf " Tags: %s\n" (String.concat ", " b.tags);
51
-
if b.archived then Printf.printf " [ARCHIVED]\n";
52
-
if b.favourited then Printf.printf " [FAVOURITED]\n";
53
-
(match b.summary with
47
+
Printf.printf " ID: %s\n" (Karakeep.bookmark_id b);
48
+
Printf.printf " Created: %s\n" (Ptime.to_rfc3339 (Karakeep.bookmark_created_at b));
49
+
let tags = Karakeep.bookmark_tags b in
50
+
if tags <> [] then
51
+
Printf.printf " Tags: %s\n" (String.concat ", " tags);
52
+
if Karakeep.bookmark_archived b then Printf.printf " [ARCHIVED]\n";
53
+
if Karakeep.bookmark_favourited b then Printf.printf " [FAVOURITED]\n";
54
+
(match Karakeep.bookmark_summary b with
54
55
| Some s when s <> "" ->
55
56
let summary = if String.length s > 100 then String.sub s 0 100 ^ "..." else s in
56
57
Printf.printf " Summary: %s\n" summary
···
79
80
let client = Karakeep.create ~sw ~env ~api_key ~base_url in
80
81
let bookmark = Karakeep.fetch_bookmark_details client bookmark_id in
81
82
82
-
Printf.printf "Bookmark: %s\n" bookmark.url;
83
-
Printf.printf "ID: %s\n" bookmark.id;
84
-
(match bookmark.title with
83
+
Printf.printf "Bookmark: %s\n" (Karakeep.bookmark_url bookmark);
84
+
Printf.printf "ID: %s\n" (Karakeep.bookmark_id bookmark);
85
+
(match Karakeep.bookmark_title bookmark with
85
86
| Some title -> Printf.printf "Title: %s\n" title
86
87
| None -> ());
87
-
(match bookmark.note with
88
+
(match Karakeep.bookmark_note bookmark with
88
89
| Some note -> Printf.printf "Note: %s\n" note
89
90
| None -> ());
90
-
Printf.printf "Created: %s\n" (Ptime.to_rfc3339 bookmark.created_at);
91
-
(match bookmark.updated_at with
91
+
Printf.printf "Created: %s\n" (Ptime.to_rfc3339 (Karakeep.bookmark_created_at bookmark));
92
+
(match Karakeep.bookmark_updated_at bookmark with
92
93
| Some t -> Printf.printf "Updated: %s\n" (Ptime.to_rfc3339 t)
93
94
| None -> ());
94
95
95
-
if bookmark.tags <> [] then
96
-
Printf.printf "Tags: %s\n" (String.concat ", " bookmark.tags);
96
+
let tags = Karakeep.bookmark_tags bookmark in
97
+
if tags <> [] then
98
+
Printf.printf "Tags: %s\n" (String.concat ", " tags);
97
99
98
-
if bookmark.archived then Printf.printf "Status: ARCHIVED\n";
99
-
if bookmark.favourited then Printf.printf "Status: FAVOURITED\n";
100
+
if Karakeep.bookmark_archived bookmark then Printf.printf "Status: ARCHIVED\n";
101
+
if Karakeep.bookmark_favourited bookmark then Printf.printf "Status: FAVOURITED\n";
100
102
101
-
(match bookmark.summary with
103
+
(match Karakeep.bookmark_summary bookmark with
102
104
| Some s when s <> "" -> Printf.printf "\nSummary:\n%s\n" s
103
105
| _ -> ());
104
106
105
-
if bookmark.content <> [] then begin
107
+
let content = Karakeep.bookmark_content bookmark in
108
+
if content <> [] then begin
106
109
Printf.printf "\nContent metadata:\n";
107
110
List.iter (fun (k, v) ->
108
111
if v <> "null" && v <> "" then
109
112
Printf.printf " %s: %s\n" k v
110
-
) bookmark.content
113
+
) content
111
114
end;
112
115
113
-
if bookmark.assets <> [] then begin
116
+
let assets = Karakeep.bookmark_assets bookmark in
117
+
if assets <> [] then begin
114
118
Printf.printf "\nAssets:\n";
115
119
List.iter (fun (id, asset_type) ->
116
120
Printf.printf " %s (%s)\n" id asset_type;
117
121
Printf.printf " URL: %s\n" (Karakeep.get_asset_url client id)
118
-
) bookmark.assets
122
+
) assets
119
123
end;
120
124
121
125
0
···
154
158
in
155
159
156
160
Printf.printf "✓ Bookmark created successfully!\n";
157
-
Printf.printf "ID: %s\n" bookmark.id;
158
-
Printf.printf "URL: %s\n" bookmark.url;
159
-
(match bookmark.title with
161
+
Printf.printf "ID: %s\n" (Karakeep.bookmark_id bookmark);
162
+
Printf.printf "URL: %s\n" (Karakeep.bookmark_url bookmark);
163
+
(match Karakeep.bookmark_title bookmark with
160
164
| Some t -> Printf.printf "Title: %s\n" t
161
165
| None -> ());
162
-
if bookmark.tags <> [] then
163
-
Printf.printf "Tags: %s\n" (String.concat ", " bookmark.tags);
166
+
let tags = Karakeep.bookmark_tags bookmark in
167
+
if tags <> [] then
168
+
Printf.printf "Tags: %s\n" (String.concat ", " tags);
164
169
0
165
170
with exn ->
166
171
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
···
197
202
(if List.length bookmarks = 1 then "" else "s");
198
203
199
204
List.iteri (fun i (b : Karakeep.bookmark) ->
200
-
Printf.printf "%d. %s\n" (i + 1) b.url;
201
-
(match b.title with
205
+
Printf.printf "%d. %s\n" (i + 1) (Karakeep.bookmark_url b);
206
+
(match Karakeep.bookmark_title b with
202
207
| Some title -> Printf.printf " Title: %s\n" title
203
208
| None -> ());
204
-
Printf.printf " ID: %s\n" b.id;
205
-
Printf.printf " Tags: %s\n" (String.concat ", " b.tags);
209
+
Printf.printf " ID: %s\n" (Karakeep.bookmark_id b);
210
+
Printf.printf " Tags: %s\n" (String.concat ", " (Karakeep.bookmark_tags b));
206
211
Printf.printf "\n"
207
212
) bookmarks;
208
213
0
+1
-1
stack/karakeep/dune
+1
-1
stack/karakeep/dune
-1
stack/karakeep/dune-project
-1
stack/karakeep/dune-project
+313
-271
stack/karakeep/karakeep.ml
+313
-271
stack/karakeep/karakeep.ml
···
1
1
(** Karakeep API client implementation (Eio version) *)
2
2
3
-
module J = Ezjsonm
4
-
5
3
let src = Logs.Src.create "karakeepe" ~doc:"Karakeep API client"
6
4
module Log = (val Logs.src_log src : Logs.LOG)
7
5
6
+
(** RFC 3339 timestamp support for JSON *)
7
+
module Rfc3339 = struct
8
+
let parse s =
9
+
Ptime.of_rfc3339 s |> Result.to_option |> Option.map (fun (t, _, _) -> t)
10
+
11
+
let format t = Ptime.to_rfc3339 ~frac_s:6 ~tz_offset_s:0 t
12
+
let _pp ppf t = Format.pp_print_string ppf (format t)
13
+
14
+
let jsont =
15
+
let kind = "RFC 3339 timestamp" in
16
+
let dec meta s =
17
+
match parse s with
18
+
| Some t -> t
19
+
| None ->
20
+
Jsont.Error.msgf meta "invalid RFC 3339 timestamp: %S" s
21
+
in
22
+
let enc = Jsont.Base.enc format in
23
+
Jsont.Base.string (Jsont.Base.map ~kind ~dec ~enc ())
24
+
end
25
+
26
+
(** Unknown JSON fields - used when keeping unknown members *)
27
+
let json_mems_empty = Jsont.Object ([], Jsont.Meta.none)
28
+
8
29
(** Type representing a Karakeep client session *)
9
30
type 'net t_internal = {
10
31
api_key: string;
···
19
40
let http_client = Requests.create ~sw env in
20
41
{ api_key; base_url; http_client }
21
42
22
-
(** Type representing a Karakeep bookmark *)
23
-
type bookmark = {
24
-
id: string;
25
-
title: string option;
26
-
url: string;
27
-
note: string option;
28
-
created_at: Ptime.t;
29
-
updated_at: Ptime.t option;
30
-
favourited: bool;
31
-
archived: bool;
32
-
tags: string list;
33
-
tagging_status: string option;
34
-
summary: string option;
35
-
content: (string * string) list;
36
-
assets: (string * string) list;
37
-
}
43
+
(** Tag type for bookmark tags *)
44
+
module Tag = struct
45
+
type t = {
46
+
name: string;
47
+
unknown: Jsont.json;
48
+
}
38
49
39
-
(** Type for Karakeep API response containing bookmarks *)
40
-
type bookmark_response = {
41
-
total: int;
42
-
data: bookmark list;
43
-
next_cursor: string option;
44
-
}
50
+
let make name unknown = { name; unknown }
51
+
let name t = t.name
52
+
let unknown t = t.unknown
45
53
46
-
(** Parse a date string to Ptime.t, defaulting to epoch if invalid *)
47
-
let parse_date str =
48
-
match Ptime.of_rfc3339 str with
49
-
| Ok (date, _, _) -> date
50
-
| Error _ ->
51
-
Fmt.epr "Warning: could not parse date '%s'\n" str;
52
-
(* Default to epoch time *)
53
-
let span_opt = Ptime.Span.of_d_ps (0, 0L) in
54
-
match span_opt with
55
-
| None -> failwith "Internal error: couldn't create epoch time span"
56
-
| Some span ->
57
-
match Ptime.of_span span with
58
-
| Some t -> t
59
-
| None -> failwith "Internal error: couldn't create epoch time"
54
+
let jsont =
55
+
let kind = "Tag" in
56
+
Jsont.Object.map ~kind make
57
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
58
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
59
+
|> Jsont.Object.finish
60
+
end
60
61
61
-
(** Extract a string field from JSON, returns None if not present or not a string *)
62
-
let get_string_opt json path =
63
-
try Some (J.find json path |> J.get_string)
64
-
with _ -> None
62
+
(** Content field pair (key-value from content object) *)
63
+
module ContentField = struct
64
+
type _t = string * string
65
65
66
-
(** Extract a string list field from JSON, returns empty list if not present *)
67
-
let get_string_list json path =
68
-
try
69
-
let items_json = J.find json path in
70
-
J.get_list (fun tag -> J.find tag ["name"] |> J.get_string) items_json
71
-
with _ -> []
66
+
let _key (k, _) = k
67
+
let _value (_, v) = v
72
68
73
-
(** Extract a boolean field from JSON, with default value *)
74
-
let get_bool_def json path default =
75
-
try J.find json path |> J.get_bool
76
-
with _ -> default
69
+
(* Helper to convert Jsont.json to string *)
70
+
let json_to_string = function
71
+
| Jsont.String (s, _) -> s
72
+
| Jsont.Bool (b, _) -> string_of_bool b
73
+
| Jsont.Number (n, _) -> string_of_float n
74
+
| Jsont.Null _ -> "null"
75
+
| _ -> "complex_value"
77
76
78
-
(** Parse a single bookmark from Karakeep JSON *)
79
-
let parse_bookmark json =
80
-
let id =
81
-
try J.find json ["id"] |> J.get_string
82
-
with e ->
83
-
Log.err (fun m -> m "Error parsing bookmark ID: %s@.JSON: %s"
84
-
(Printexc.to_string e) (J.value_to_string json));
85
-
failwith "Unable to parse bookmark ID"
86
-
in
77
+
(* Decode from JSON object members *)
78
+
let of_json_mems mems =
79
+
List.map (fun ((k, _meta), v) -> (k, json_to_string v)) mems
87
80
88
-
let title =
89
-
try Some (J.find json ["title"] |> J.get_string)
90
-
with _ -> None
91
-
in
81
+
(* Encode to JSON object members *)
82
+
let to_json_mems fields =
83
+
List.map (fun (k, v) -> ((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))) fields
84
+
end
92
85
93
-
let url =
94
-
try J.find json ["url"] |> J.get_string
95
-
with _ -> try
96
-
J.find json ["content"; "url"] |> J.get_string
97
-
with _ -> try
98
-
J.find json ["content"; "sourceUrl"] |> J.get_string
99
-
with _ ->
100
-
match J.find_opt json ["content"; "type"] with
101
-
| Some (`String "asset") ->
102
-
(try J.find json ["content"; "sourceUrl"] |> J.get_string
103
-
with _ ->
104
-
(match J.find_opt json ["id"] with
105
-
| Some (`String id) -> "karakeep-asset://" ^ id
106
-
| _ -> failwith "No URL or asset ID found in bookmark"))
107
-
| _ ->
108
-
Log.err (fun m -> m "No URL found in bookmark@.JSON structure: %s"
109
-
(J.value_to_string json));
110
-
failwith "No URL found in bookmark"
111
-
in
86
+
(** Asset type *)
87
+
module Asset = struct
88
+
type t = {
89
+
id: string;
90
+
asset_type: string;
91
+
unknown: Jsont.json;
92
+
}
112
93
113
-
let note = get_string_opt json ["note"] in
94
+
let make id asset_type unknown = { id; asset_type; unknown }
95
+
let id t = t.id
96
+
let asset_type t = t.asset_type
97
+
let unknown t = t.unknown
114
98
115
-
let created_at =
116
-
try J.find json ["createdAt"] |> J.get_string |> parse_date
117
-
with _ ->
118
-
try J.find json ["created_at"] |> J.get_string |> parse_date
119
-
with _ -> failwith "No creation date found"
120
-
in
99
+
let jsont =
100
+
let kind = "Asset" in
101
+
Jsont.Object.map ~kind make
102
+
|> Jsont.Object.mem "id" Jsont.string ~enc:id
103
+
|> Jsont.Object.mem "assetType" Jsont.string ~enc:asset_type
104
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
105
+
|> Jsont.Object.finish
106
+
end
121
107
122
-
let updated_at =
123
-
try Some (J.find json ["updatedAt"] |> J.get_string |> parse_date)
124
-
with _ ->
125
-
try Some (J.find json ["modifiedAt"] |> J.get_string |> parse_date)
126
-
with _ -> None
127
-
in
108
+
(** Karakeep bookmark *)
109
+
module Bookmark = struct
110
+
type t = {
111
+
id: string;
112
+
title: string option;
113
+
url: string;
114
+
note: string option;
115
+
created_at: Ptime.t;
116
+
updated_at: Ptime.t option;
117
+
favourited: bool;
118
+
archived: bool;
119
+
tags: string list;
120
+
tagging_status: string option;
121
+
summary: string option;
122
+
content: (string * string) list;
123
+
assets: (string * string) list;
124
+
}
128
125
129
-
let favourited = get_bool_def json ["favourited"] false in
130
-
let archived = get_bool_def json ["archived"] false in
131
-
let tags = get_string_list json ["tags"] in
132
-
let tagging_status = get_string_opt json ["taggingStatus"] in
133
-
let summary = get_string_opt json ["summary"] in
126
+
let id t = t.id
127
+
let title t = t.title
128
+
let url t = t.url
129
+
let note t = t.note
130
+
let created_at t = t.created_at
131
+
let updated_at t = t.updated_at
132
+
let favourited t = t.favourited
133
+
let archived t = t.archived
134
+
let tags t = t.tags
135
+
let tagging_status t = t.tagging_status
136
+
let summary t = t.summary
137
+
let content t = t.content
138
+
let assets t = t.assets
134
139
135
-
let content =
136
-
try
137
-
let content_json = J.find json ["content"] in
138
-
let rec extract_fields acc = function
139
-
| [] -> acc
140
-
| (k, v) :: rest ->
141
-
let value = match v with
142
-
| `String s -> s
143
-
| `Bool b -> string_of_bool b
144
-
| `Float f -> string_of_float f
145
-
| `Null -> "null"
146
-
| _ -> "complex_value"
147
-
in
148
-
extract_fields ((k, value) :: acc) rest
140
+
let jsont =
141
+
let kind = "Bookmark" in
142
+
143
+
(* Constructor for decoding *)
144
+
let make id title url note created_at updated_at favourited archived
145
+
tag_objs tagging_status summary content_obj assets_objs _unknown =
146
+
147
+
(* Extract tag names from tag objects *)
148
+
let tags = match tag_objs with
149
+
| Some tags -> List.map Tag.name tags
150
+
| None -> []
151
+
in
152
+
153
+
(* Extract content fields from JSON object *)
154
+
let content = match content_obj with
155
+
| Some (Jsont.Object (mems, _)) -> ContentField.of_json_mems mems
156
+
| _ -> []
149
157
in
150
-
match content_json with
151
-
| `O fields -> extract_fields [] fields
152
-
| _ -> []
153
-
with _ -> []
154
-
in
155
158
156
-
let assets =
157
-
try
158
-
let assets_json = J.find json ["assets"] in
159
-
J.get_list (fun asset_json ->
160
-
let id = J.find asset_json ["id"] |> J.get_string in
161
-
let asset_type =
162
-
try J.find asset_json ["assetType"] |> J.get_string
163
-
with _ -> "unknown"
164
-
in
165
-
(id, asset_type)
166
-
) assets_json
167
-
with _ -> []
168
-
in
159
+
(* Extract asset tuples *)
160
+
let assets = match assets_objs with
161
+
| Some asset_list -> List.map (fun a -> (Asset.id a, Asset.asset_type a)) asset_list
162
+
| None -> []
163
+
in
169
164
170
-
{ id; title; url; note; created_at; updated_at; favourited; archived; tags;
171
-
tagging_status; summary; content; assets }
165
+
(* Handle URL extraction from content if main URL is missing *)
166
+
let url = match url with
167
+
| Some u -> u
168
+
| None ->
169
+
(* Try to find URL in content *)
170
+
(match List.assoc_opt "url" content with
171
+
| Some u -> u
172
+
| None ->
173
+
(match List.assoc_opt "sourceUrl" content with
174
+
| Some u -> u
175
+
| None ->
176
+
(* Check if it's an asset type *)
177
+
(match List.assoc_opt "type" content with
178
+
| Some "asset" ->
179
+
(match List.assoc_opt "sourceUrl" content with
180
+
| Some u -> u
181
+
| None -> "karakeep-asset://" ^ id)
182
+
| _ -> "unknown://no-url")))
183
+
in
184
+
185
+
{
186
+
id;
187
+
title;
188
+
url;
189
+
note;
190
+
created_at;
191
+
updated_at;
192
+
favourited = Option.value ~default:false favourited;
193
+
archived = Option.value ~default:false archived;
194
+
tags;
195
+
tagging_status;
196
+
summary;
197
+
content;
198
+
assets;
199
+
}
200
+
in
201
+
202
+
Jsont.Object.map ~kind make
203
+
|> Jsont.Object.mem "id" Jsont.string ~enc:id
204
+
|> Jsont.Object.opt_mem "title" Jsont.string ~enc:title
205
+
|> Jsont.Object.opt_mem "url" Jsont.string ~enc:(fun t -> Some t.url)
206
+
|> Jsont.Object.opt_mem "note" Jsont.string ~enc:note
207
+
|> Jsont.Object.mem "createdAt" Rfc3339.jsont ~enc:created_at
208
+
|> Jsont.Object.opt_mem "updatedAt" Rfc3339.jsont ~enc:updated_at
209
+
|> Jsont.Object.opt_mem "favourited" Jsont.bool ~enc:(fun t -> Some t.favourited)
210
+
|> Jsont.Object.opt_mem "archived" Jsont.bool ~enc:(fun t -> Some t.archived)
211
+
|> Jsont.Object.opt_mem "tags" (Jsont.list Tag.jsont)
212
+
~enc:(fun t -> if t.tags = [] then None else
213
+
Some (List.map (fun name -> Tag.make name json_mems_empty) t.tags))
214
+
|> Jsont.Object.opt_mem "taggingStatus" Jsont.string ~enc:tagging_status
215
+
|> Jsont.Object.opt_mem "summary" Jsont.string ~enc:summary
216
+
|> Jsont.Object.opt_mem "content" Jsont.json
217
+
~enc:(fun t -> if t.content = [] then None else
218
+
Some (Jsont.Object (ContentField.to_json_mems t.content, Jsont.Meta.none)))
219
+
|> Jsont.Object.opt_mem "assets" (Jsont.list Asset.jsont)
220
+
~enc:(fun t -> if t.assets = [] then None else
221
+
Some (List.map (fun (id, asset_type) ->
222
+
Asset.make id asset_type json_mems_empty) t.assets))
223
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> json_mems_empty)
224
+
|> Jsont.Object.finish
225
+
end
226
+
227
+
(* Compatibility type aliases and accessors *)
228
+
type bookmark = Bookmark.t
229
+
let bookmark_id = Bookmark.id
230
+
let bookmark_title = Bookmark.title
231
+
let bookmark_url = Bookmark.url
232
+
let bookmark_note = Bookmark.note
233
+
let bookmark_created_at = Bookmark.created_at
234
+
let bookmark_updated_at = Bookmark.updated_at
235
+
let bookmark_favourited = Bookmark.favourited
236
+
let bookmark_archived = Bookmark.archived
237
+
let bookmark_tags = Bookmark.tags
238
+
let bookmark_tagging_status = Bookmark.tagging_status
239
+
let bookmark_summary = Bookmark.summary
240
+
let bookmark_content = Bookmark.content
241
+
let bookmark_assets = Bookmark.assets
242
+
243
+
(** Karakeep API response containing bookmarks *)
244
+
module BookmarkResponse = struct
245
+
type t = {
246
+
total: int;
247
+
data: bookmark list;
248
+
next_cursor: string option;
249
+
}
250
+
251
+
let make total data next_cursor = { total; data; next_cursor }
252
+
let total t = t.total
253
+
let data t = t.data
254
+
let next_cursor t = t.next_cursor
255
+
256
+
(* Format 1: {total, data, nextCursor} *)
257
+
let format1_jsont =
258
+
let kind = "BookmarkResponse" in
259
+
let make total data next_cursor _unknown =
260
+
{ total; data; next_cursor }
261
+
in
262
+
Jsont.Object.map ~kind make
263
+
|> Jsont.Object.mem "total" Jsont.int ~enc:total
264
+
|> Jsont.Object.mem "data" (Jsont.list Bookmark.jsont) ~enc:data
265
+
|> Jsont.Object.opt_mem "nextCursor" Jsont.string ~enc:next_cursor
266
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> json_mems_empty)
267
+
|> Jsont.Object.finish
268
+
269
+
(* Format 2: {bookmarks, nextCursor} *)
270
+
let format2_jsont =
271
+
let kind = "BookmarkResponse" in
272
+
let make data next_cursor _unknown =
273
+
{ total = List.length data; data; next_cursor }
274
+
in
275
+
Jsont.Object.map ~kind make
276
+
|> Jsont.Object.mem "bookmarks" (Jsont.list Bookmark.jsont) ~enc:data
277
+
|> Jsont.Object.opt_mem "nextCursor" Jsont.string ~enc:next_cursor
278
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> json_mems_empty)
279
+
|> Jsont.Object.finish
280
+
end
281
+
282
+
(* Compatibility type aliases and accessors *)
283
+
type bookmark_response = BookmarkResponse.t
284
+
let response_total = BookmarkResponse.total
285
+
let response_data = BookmarkResponse.data
286
+
let response_next_cursor = BookmarkResponse.next_cursor
172
287
173
288
(** Parse a Karakeep bookmark response - handles multiple API response formats *)
174
-
let parse_bookmark_response json =
175
-
Log.debug (fun m -> m "Parsing API response: %s" (J.value_to_string json));
289
+
let parse_bookmark_response json_str =
290
+
Log.debug (fun m -> m "Parsing API response (%d bytes)" (String.length json_str));
176
291
177
292
(* Try format 1: {total: int, data: [...], nextCursor?: string} *)
178
293
let try_format1 () =
179
294
Log.debug (fun m -> m "Trying format 1: {total, data, nextCursor}");
180
-
let total = J.find json ["total"] |> J.get_int in
181
-
let bookmarks_json = J.find json ["data"] in
182
-
let data = J.get_list parse_bookmark bookmarks_json in
183
-
let next_cursor =
184
-
try Some (J.find json ["nextCursor"] |> J.get_string)
185
-
with _ -> None
186
-
in
187
-
Log.debug (fun m -> m "Successfully parsed format 1: %d bookmarks" (List.length data));
188
-
{ total; data; next_cursor }
295
+
match Jsont_bytesrw.decode_string' BookmarkResponse.format1_jsont json_str with
296
+
| Ok response ->
297
+
Log.debug (fun m -> m "Successfully parsed format 1: %d bookmarks" (List.length response.data));
298
+
response
299
+
| Error e ->
300
+
Log.debug (fun m -> m "Format 1 failed: %s" (Jsont.Error.to_string e));
301
+
raise Not_found
189
302
in
190
303
191
-
(* Try format 2: {bookmarks: [...], nextCursor?: string} - no total field *)
304
+
(* Try format 2: {bookmarks: [...], nextCursor?: string} *)
192
305
let try_format2 () =
193
306
Log.debug (fun m -> m "Trying format 2: {bookmarks, nextCursor}");
194
-
let bookmarks_json = J.find json ["bookmarks"] in
195
-
let data = J.get_list parse_bookmark bookmarks_json in
196
-
let next_cursor =
197
-
try Some (J.find json ["nextCursor"] |> J.get_string)
198
-
with _ -> None
199
-
in
200
-
(* Calculate total from data length when total field is missing *)
201
-
let total = List.length data in
202
-
Log.debug (fun m -> m "Successfully parsed format 2: %d bookmarks" total);
203
-
{ total; data; next_cursor }
204
-
in
205
-
206
-
(* Try format 3: API error response {error: string, message?: string} *)
207
-
let try_error_format () =
208
-
Log.debug (fun m -> m "Checking for API error response");
209
-
let error = J.find json ["error"] |> J.get_string in
210
-
let message =
211
-
try J.find json ["message"] |> J.get_string
212
-
with _ -> "Unknown error"
213
-
in
214
-
Log.err (fun m -> m "API returned error: %s - %s" error message);
215
-
{ total = 0; data = []; next_cursor = None }
307
+
match Jsont_bytesrw.decode_string' BookmarkResponse.format2_jsont json_str with
308
+
| Ok response ->
309
+
Log.debug (fun m -> m "Successfully parsed format 2: %d bookmarks" (List.length response.data));
310
+
response
311
+
| Error e ->
312
+
Log.debug (fun m -> m "Format 2 failed: %s" (Jsont.Error.to_string e));
313
+
raise Not_found
216
314
in
217
315
218
-
(* Try format 4: Plain array at root level *)
316
+
(* Try format 3: Plain array at root level *)
219
317
let try_array_format () =
220
-
Log.debug (fun m -> m "Trying format 4: array at root");
221
-
match json with
222
-
| `A _ ->
223
-
let data = J.get_list parse_bookmark json in
318
+
Log.debug (fun m -> m "Trying format 3: array at root");
319
+
let array_jsont = Jsont.list Bookmark.jsont in
320
+
match Jsont_bytesrw.decode_string' array_jsont json_str with
321
+
| Ok data ->
224
322
Log.debug (fun m -> m "Successfully parsed array format: %d bookmarks" (List.length data));
225
-
{ total = List.length data; data; next_cursor = None }
226
-
| _ -> raise Not_found
323
+
BookmarkResponse.make (List.length data) data None
324
+
| Error e ->
325
+
Log.debug (fun m -> m "Array format failed: %s" (Jsont.Error.to_string e));
326
+
raise Not_found
227
327
in
228
328
229
329
(* Try each format in order *)
230
330
try try_format1 ()
231
-
with _ -> (
331
+
with Not_found -> (
232
332
try try_format2 ()
233
-
with _ -> (
234
-
try try_error_format ()
235
-
with _ -> (
236
-
try try_array_format ()
237
-
with _ ->
238
-
Log.err (fun m -> m "Failed to parse response in any known format");
239
-
Log.debug (fun m -> m "JSON keys: %s"
240
-
(match json with
241
-
| `O fields -> String.concat ", " (List.map fst fields)
242
-
| _ -> "not an object"));
243
-
{ total = 0; data = []; next_cursor = None }
244
-
)
333
+
with Not_found -> (
334
+
try try_array_format ()
335
+
with Not_found ->
336
+
Log.err (fun m -> m "Failed to parse response in any known format");
337
+
Log.debug (fun m -> m "Response preview: %s"
338
+
(if String.length json_str > 200 then String.sub json_str 0 200 ^ "..." else json_str));
339
+
BookmarkResponse.make 0 [] None
245
340
)
246
341
)
247
342
···
277
372
match Requests_json_api.check_ok response with
278
373
| Ok body_str ->
279
374
Log.debug (fun m -> m "Received %d bytes of response data" (String.length body_str));
280
-
(try
281
-
let json = J.from_string body_str in
282
-
parse_bookmark_response json
283
-
with e ->
284
-
Log.err (fun m -> m "JSON parsing error: %s" (Printexc.to_string e));
285
-
Log.debug (fun m -> m "Response body (first 200 chars): %s"
286
-
(if String.length body_str > 200 then String.sub body_str 0 200 ^ "..." else body_str));
287
-
raise e)
375
+
parse_bookmark_response body_str
288
376
| Error (status_code, _) ->
289
377
Log.err (fun m -> m "HTTP error %d" status_code);
290
378
failwith (Fmt.str "HTTP error: %d" status_code)
···
325
413
| _ -> all_bookmarks
326
414
in
327
415
328
-
(* Determine if more pages are available:
329
-
- If next_cursor is present, there are definitely more pages
330
-
- If no next_cursor and we got fewer items than page_size, we're done
331
-
- If no next_cursor and total is reliable (> current count), there may be more *)
416
+
(* Determine if more pages are available *)
332
417
let more_available =
333
418
match response.next_cursor with
334
419
| Some _ ->
···
338
423
let current_count = List.length all_bookmarks in
339
424
let got_full_page = List.length response.data = page_size in
340
425
let total_indicates_more = response.total > current_count in
341
-
(* If we got a full page and total indicates more, continue *)
342
426
let has_more = got_full_page && total_indicates_more in
343
427
if has_more then
344
428
Log.debug (fun m -> m "More pages likely available (%d fetched < %d total)"
···
380
464
let response = Requests.get client.http_client ~headers url in
381
465
match check_ok response with
382
466
| Ok body_str ->
383
-
let json = J.from_string body_str in
384
-
parse_bookmark json
467
+
(match Jsont_bytesrw.decode_string' Bookmark.jsont body_str with
468
+
| Ok bookmark -> bookmark
469
+
| Error e ->
470
+
failwith (Fmt.str "Failed to parse bookmark: %s" (Jsont.Error.to_string e)))
385
471
| Error (status_code, _) ->
386
472
failwith (Fmt.str "HTTP error: %d" status_code)
387
473
···
405
491
406
492
(** Create a new bookmark in Karakeep with optional tags *)
407
493
let create_bookmark client ~url ?title ?note ?tags ?(favourited=false) ?(archived=false) () =
494
+
let meta = Jsont.Meta.none in
408
495
let body_obj = [
409
-
("type", `String "link");
410
-
("url", `String url);
411
-
("favourited", `Bool favourited);
412
-
("archived", `Bool archived);
496
+
(("type", meta), Jsont.String ("link", meta));
497
+
(("url", meta), Jsont.String (url, meta));
498
+
(("favourited", meta), Jsont.Bool (favourited, meta));
499
+
(("archived", meta), Jsont.Bool (archived, meta));
413
500
] in
414
501
415
502
let body_obj = match title with
416
-
| Some title_str -> ("title", `String title_str) :: body_obj
503
+
| Some title_str -> (("title", meta), Jsont.String (title_str, meta)) :: body_obj
417
504
| None -> body_obj
418
505
in
419
506
420
507
let body_obj = match note with
421
-
| Some note_str -> ("note", `String note_str) :: body_obj
508
+
| Some note_str -> (("note", meta), Jsont.String (note_str, meta)) :: body_obj
422
509
| None -> body_obj
423
510
in
424
511
425
-
let body_json = `O body_obj in
426
-
let body_str = J.to_string body_json in
512
+
let body_json = Jsont.Object (body_obj, meta) in
513
+
let body_str = match Jsont_bytesrw.encode_string' Jsont.json body_json with
514
+
| Ok s -> s
515
+
| Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))
516
+
in
427
517
428
518
let headers = Requests.Headers.empty
429
519
|> Requests.Headers.set "Authorization" ("Bearer " ^ client.api_key)
···
438
528
let status_code = Requests.Response.status_code response in
439
529
if status_code = 201 || status_code = 200 then begin
440
530
let body_str = read_body response in
441
-
let json = J.from_string body_str in
442
-
let bookmark = parse_bookmark json in
531
+
let bookmark = match Jsont_bytesrw.decode_string' Bookmark.jsont body_str with
532
+
| Ok b -> b
533
+
| Error e -> failwith (Fmt.str "Failed to parse created bookmark: %s" (Jsont.Error.to_string e))
534
+
in
443
535
444
536
match tags with
445
537
| Some tag_list when tag_list <> [] ->
446
538
let tag_objects = List.map (fun tag_name ->
447
-
`O [("tagName", `String tag_name)]
539
+
Jsont.Object ([(("tagName", meta), Jsont.String (tag_name, meta))], meta)
448
540
) tag_list in
449
541
450
-
let tags_body = `O [("tags", `A tag_objects)] in
451
-
let tags_body_str = J.to_string tags_body in
542
+
let tags_body = Jsont.Object ([(("tags", meta), Jsont.Array (tag_objects, meta))], meta) in
543
+
let tags_body_str = match Jsont_bytesrw.encode_string' Jsont.json tags_body with
544
+
| Ok s -> s
545
+
| Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))
546
+
in
452
547
453
548
let tags_url = client.base_url / "api/v1/bookmarks" / bookmark.id / "tags" in
454
549
let tags_body = Requests.Body.of_string Requests.Mime.json tags_body_str in
···
464
559
let error_body = read_body response in
465
560
failwith (Fmt.str "Failed to create bookmark. HTTP error: %d. Details: %s" status_code error_body)
466
561
end
467
-
468
-
(** Convert a Karakeep bookmark to Bushel.Link.t compatible structure *)
469
-
let to_bushel_link ?base_url bookmark =
470
-
let description =
471
-
match bookmark.title with
472
-
| Some title when title <> "" -> title
473
-
| _ ->
474
-
let content_title = List.assoc_opt "title" bookmark.content in
475
-
match content_title with
476
-
| Some title when title <> "" && title <> "null" -> title
477
-
| _ -> bookmark.url
478
-
in
479
-
let date = Ptime.to_date bookmark.created_at in
480
-
481
-
let metadata =
482
-
(match bookmark.summary with Some s -> [("summary", s)] | None -> []) @
483
-
(List.filter_map (fun (id, asset_type) ->
484
-
match asset_type with
485
-
| "screenshot" | "bannerImage" -> Some (asset_type, id)
486
-
| _ -> None
487
-
) bookmark.assets) @
488
-
(List.filter_map (fun (k, v) ->
489
-
if k = "favicon" && v <> "" && v <> "null" then Some ("favicon", v) else None
490
-
) bookmark.content)
491
-
in
492
-
493
-
let karakeep =
494
-
match base_url with
495
-
| Some url ->
496
-
Some {
497
-
Bushel.Link.remote_url = url;
498
-
id = bookmark.id;
499
-
tags = bookmark.tags;
500
-
metadata = metadata;
501
-
}
502
-
| None -> None
503
-
in
504
-
505
-
let bushel_slugs =
506
-
List.filter_map (fun tag ->
507
-
if String.starts_with ~prefix:"bushel:" tag then
508
-
Some (String.sub tag 7 (String.length tag - 7))
509
-
else
510
-
None
511
-
) bookmark.tags
512
-
in
513
-
514
-
let bushel =
515
-
if bushel_slugs = [] then None
516
-
else Some { Bushel.Link.slugs = bushel_slugs; tags = [] }
517
-
in
518
-
519
-
{ Bushel.Link.url = bookmark.url; date; description; karakeep; bushel }
+23
-28
stack/karakeep/karakeep.mli
+23
-28
stack/karakeep/karakeep.mli
···
19
19
t
20
20
21
21
(** Type representing a Karakeep bookmark *)
22
-
type bookmark = {
23
-
id: string;
24
-
title: string option;
25
-
url: string;
26
-
note: string option;
27
-
created_at: Ptime.t;
28
-
updated_at: Ptime.t option;
29
-
favourited: bool;
30
-
archived: bool;
31
-
tags: string list;
32
-
tagging_status: string option;
33
-
summary: string option;
34
-
content: (string * string) list;
35
-
assets: (string * string) list;
36
-
}
22
+
type bookmark
23
+
24
+
(** Bookmark accessors *)
25
+
val bookmark_id : bookmark -> string
26
+
val bookmark_title : bookmark -> string option
27
+
val bookmark_url : bookmark -> string
28
+
val bookmark_note : bookmark -> string option
29
+
val bookmark_created_at : bookmark -> Ptime.t
30
+
val bookmark_updated_at : bookmark -> Ptime.t option
31
+
val bookmark_favourited : bookmark -> bool
32
+
val bookmark_archived : bookmark -> bool
33
+
val bookmark_tags : bookmark -> string list
34
+
val bookmark_tagging_status : bookmark -> string option
35
+
val bookmark_summary : bookmark -> string option
36
+
val bookmark_content : bookmark -> (string * string) list
37
+
val bookmark_assets : bookmark -> (string * string) list
37
38
38
39
(** Type for Karakeep API response containing bookmarks *)
39
-
type bookmark_response = {
40
-
total: int;
41
-
data: bookmark list;
42
-
next_cursor: string option;
43
-
}
40
+
type bookmark_response
44
41
45
-
(** Parse a single bookmark from Karakeep JSON *)
46
-
val parse_bookmark : Ezjsonm.value -> bookmark
42
+
(** Bookmark response accessors *)
43
+
val response_total : bookmark_response -> int
44
+
val response_data : bookmark_response -> bookmark list
45
+
val response_next_cursor : bookmark_response -> string option
47
46
48
-
(** Parse a Karakeep bookmark response *)
49
-
val parse_bookmark_response : Ezjsonm.value -> bookmark_response
47
+
(** Parse a Karakeep bookmark response from a JSON string *)
48
+
val parse_bookmark_response : string -> bookmark_response
50
49
51
50
(** Fetch bookmarks from a Karakeep instance with pagination support
52
51
@param client Karakeep client instance
···
92
91
t ->
93
92
string ->
94
93
bookmark
95
-
96
-
(** Convert a Karakeep bookmark to Bushel.Link.t compatible structure
97
-
@param base_url Optional base URL of the Karakeep instance (for karakeep_id) *)
98
-
val to_bushel_link : ?base_url:string -> bookmark -> Bushel.Link.t
99
94
100
95
(** Fetch an asset from the Karakeep server as a binary string
101
96
@param client Karakeep client instance
-1
stack/karakeep/karakeep.opam
-1
stack/karakeep/karakeep.opam
+8
-4
stack/peertubee/bin/peertubee_cli.ml
+8
-4
stack/peertubee/bin/peertubee_cli.ml
···
36
36
Printf.printf " Description: %s\n" desc_short
37
37
| None -> ());
38
38
Printf.printf " Published: %s\n" (Ptime.to_rfc3339 v.published_at);
39
-
if v.tags <> [] then
40
-
Printf.printf " Tags: %s\n" (String.concat ", " v.tags);
39
+
(match v.tags with
40
+
| Some tags when tags <> [] ->
41
+
Printf.printf " Tags: %s\n" (String.concat ", " tags)
42
+
| _ -> ());
41
43
Printf.printf "\n"
42
44
) videos;
43
45
0
···
73
75
(match video.originally_published_at with
74
76
| Some t -> Printf.printf "Originally published: %s\n" (Ptime.to_rfc3339 t)
75
77
| None -> ());
76
-
if video.tags <> [] then
77
-
Printf.printf "Tags: %s\n" (String.concat ", " video.tags);
78
+
(match video.tags with
79
+
| Some tags when tags <> [] ->
80
+
Printf.printf "Tags: %s\n" (String.concat ", " tags)
81
+
| _ -> ());
78
82
(match Peertubee.thumbnail_url client video with
79
83
| Some url -> Printf.printf "Thumbnail: %s\n" url
80
84
| None -> ());
+1
-1
stack/peertubee/dune
+1
-1
stack/peertubee/dune
-1
stack/peertubee/dune-project
-1
stack/peertubee/dune-project
+85
-55
stack/peertubee/peertubee.ml
+85
-55
stack/peertubee/peertubee.ml
···
1
1
(** PeerTube API client implementation (Eio version) *)
2
2
3
-
module J = Ezjsonm
4
-
5
3
(** Type representing a PeerTube client *)
6
4
type 'net t_internal = {
7
5
base_url: string;
···
25
23
published_at: Ptime.t;
26
24
originally_published_at: Ptime.t option;
27
25
thumbnail_path: string option;
28
-
tags: string list;
26
+
tags: string list option;
27
+
unknown: Jsont.json;
29
28
}
30
29
31
30
(** Type for PeerTube API response containing videos *)
32
31
type video_response = {
33
32
total: int;
34
33
data: video list;
34
+
unknown: Jsont.json;
35
35
}
36
36
37
-
(** Parse a date string to Ptime.t, defaulting to epoch if invalid *)
38
-
let parse_date str =
39
-
match Ptime.of_rfc3339 str with
40
-
| Ok (date, _, _) -> date
41
-
| Error _ ->
42
-
Fmt.epr "Warning: could not parse date '%s'\n" str;
43
-
(* Default to epoch time *)
44
-
let span_opt = Ptime.Span.of_d_ps (0, 0L) in
45
-
match span_opt with
46
-
| None -> failwith "Internal error: couldn't create epoch time span"
47
-
| Some span ->
48
-
match Ptime.of_span span with
49
-
| Some t -> t
50
-
| None -> failwith "Internal error: couldn't create epoch time"
37
+
(** Accessor functions for video *)
38
+
let video_id (v : video) = v.id
39
+
let video_uuid (v : video) = v.uuid
40
+
let video_name (v : video) = v.name
41
+
let video_description (v : video) = v.description
42
+
let video_url (v : video) = v.url
43
+
let video_embed_path (v : video) = v.embed_path
44
+
let video_published_at (v : video) = v.published_at
45
+
let video_originally_published_at (v : video) = v.originally_published_at
46
+
let video_thumbnail_path (v : video) = v.thumbnail_path
47
+
let video_tags (v : video) = v.tags
48
+
let video_unknown (v : video) = v.unknown
51
49
52
-
(** Extract a string field from JSON, returns None if not present or not a string *)
53
-
let get_string_opt json path =
54
-
try Some (J.find json path |> J.get_string)
55
-
with _ -> None
50
+
(** Accessor functions for video_response *)
51
+
let video_response_total (vr : video_response) = vr.total
52
+
let video_response_data (vr : video_response) = vr.data
53
+
let video_response_unknown (vr : video_response) = vr.unknown
56
54
57
-
(** Extract a string list field from JSON, returns empty list if not present *)
58
-
let get_string_list json path =
59
-
try
60
-
let tags_json = J.find json path in
61
-
J.get_list J.get_string tags_json
62
-
with _ -> []
55
+
(** RFC3339 timestamp codec *)
56
+
module Rfc3339 = struct
57
+
let parse s =
58
+
Ptime.of_rfc3339 s |> Result.to_option |> Option.map (fun (t, _, _) -> t)
63
59
64
-
(** Parse a single video from PeerTube JSON *)
65
-
let parse_video json =
66
-
let id = J.find json ["id"] |> J.get_int in
67
-
let uuid = J.find json ["uuid"] |> J.get_string in
68
-
let name = J.find json ["name"] |> J.get_string in
69
-
let description = get_string_opt json ["description"] in
70
-
let url = J.find json ["url"] |> J.get_string in
71
-
let embed_path = J.find json ["embedPath"] |> J.get_string in
60
+
let format t = Ptime.to_rfc3339 ~frac_s:6 ~tz_offset_s:0 t
61
+
let pp ppf t = Format.pp_print_string ppf (format t)
72
62
73
-
(* Parse dates *)
74
-
let published_at =
75
-
J.find json ["publishedAt"] |> J.get_string |> parse_date
63
+
let jsont =
64
+
let kind = "RFC 3339 timestamp" in
65
+
let doc = "An RFC 3339 date-time string" in
66
+
let dec s =
67
+
match parse s with
68
+
| Some t -> t
69
+
| None ->
70
+
Jsont.Error.msgf Jsont.Meta.none "%s: invalid RFC 3339 timestamp: %S"
71
+
kind s
72
+
in
73
+
Jsont.map ~kind ~doc ~dec ~enc:format Jsont.string
74
+
end
75
+
76
+
(** Jsont codec for video *)
77
+
let video_jsont : video Jsont.t =
78
+
let kind = "PeerTube Video" in
79
+
let doc = "A PeerTube video object" in
80
+
81
+
let make_video id uuid name description url embed_path published_at
82
+
originally_published_at thumbnail_path tags unknown : video =
83
+
{ id; uuid; name; description; url; embed_path; published_at;
84
+
originally_published_at; thumbnail_path; tags; unknown }
76
85
in
77
86
78
-
let originally_published_at =
79
-
match get_string_opt json ["originallyPublishedAt"] with
80
-
| Some date -> Some (parse_date date)
81
-
| None -> None
87
+
Jsont.Object.map ~kind ~doc make_video
88
+
|> Jsont.Object.mem "id" Jsont.int ~enc:video_id
89
+
|> Jsont.Object.mem "uuid" Jsont.string ~enc:video_uuid
90
+
|> Jsont.Object.mem "name" Jsont.string ~enc:video_name
91
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:video_description
92
+
|> Jsont.Object.mem "url" Jsont.string ~enc:video_url
93
+
|> Jsont.Object.mem "embedPath" Jsont.string ~enc:video_embed_path
94
+
|> Jsont.Object.mem "publishedAt" Rfc3339.jsont ~enc:video_published_at
95
+
|> Jsont.Object.opt_mem "originallyPublishedAt" Rfc3339.jsont ~enc:video_originally_published_at
96
+
|> Jsont.Object.opt_mem "thumbnailPath" Jsont.string ~enc:video_thumbnail_path
97
+
|> Jsont.Object.opt_mem "tags" (Jsont.list Jsont.string) ~enc:video_tags
98
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:video_unknown
99
+
|> Jsont.Object.finish
100
+
101
+
(** Jsont codec for video_response *)
102
+
let video_response_jsont =
103
+
let kind = "PeerTube Video Response" in
104
+
let doc = "A PeerTube API response containing videos" in
105
+
106
+
let make_response total data unknown =
107
+
{ total; data; unknown }
82
108
in
83
109
84
-
let thumbnail_path = get_string_opt json ["thumbnailPath"] in
85
-
let tags = get_string_list json ["tags"] in
110
+
Jsont.Object.map ~kind ~doc make_response
111
+
|> Jsont.Object.mem "total" Jsont.int ~enc:video_response_total
112
+
|> Jsont.Object.mem "data" (Jsont.list video_jsont) ~enc:video_response_data
113
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:video_response_unknown
114
+
|> Jsont.Object.finish
86
115
87
-
{ id; uuid; name; description; url; embed_path;
88
-
published_at; originally_published_at;
89
-
thumbnail_path; tags }
116
+
(** Parse a single video from JSON string *)
117
+
let parse_video_string s =
118
+
match Jsont_bytesrw.decode_string' video_jsont s with
119
+
| Ok video -> video
120
+
| Error err -> failwith (Jsont.Error.to_string err)
90
121
91
-
(** Parse a PeerTube video response *)
92
-
let parse_video_response json =
93
-
let total = J.find json ["total"] |> J.get_int in
94
-
let videos_json = J.find json ["data"] in
95
-
let data = J.get_list parse_video videos_json in
96
-
{ total; data }
122
+
(** Parse a video response from JSON string *)
123
+
let parse_video_response_string s =
124
+
match Jsont_bytesrw.decode_string' video_response_jsont s with
125
+
| Ok response -> response
126
+
| Error err -> failwith (Jsont.Error.to_string err)
97
127
98
128
(** Fetch videos from a PeerTube instance channel with pagination support
99
129
@param count Number of videos to fetch per page
···
105
135
let open Requests_json_api in
106
136
let url = Printf.sprintf "%s/api/v1/video-channels/%s/videos?count=%d&start=%d"
107
137
client.base_url channel count start in
108
-
get_json_exn client.requests_session url parse_video_response
138
+
get_json_exn client.requests_session url video_response_jsont
109
139
110
140
(** Fetch all videos from a PeerTube instance channel using pagination
111
141
@param page_size Number of videos to fetch per page
···
140
170
let fetch_video_details client uuid =
141
171
let open Requests_json_api in
142
172
let url = client.base_url / "api/v1/videos" / uuid in
143
-
get_json_exn client.requests_session url parse_video
173
+
get_json_exn client.requests_session url video_jsont
144
174
145
175
(** Convert a PeerTube video to Bushel.Video.t compatible structure *)
146
176
let to_bushel_video video =
+33
-5
stack/peertubee/peertubee.mli
+33
-5
stack/peertubee/peertubee.mli
···
23
23
published_at: Ptime.t;
24
24
originally_published_at: Ptime.t option;
25
25
thumbnail_path: string option;
26
-
tags: string list;
26
+
tags: string list option;
27
+
unknown: Jsont.json;
27
28
}
28
29
29
30
(** Type for PeerTube API response containing videos *)
30
31
type video_response = {
31
32
total: int;
32
33
data: video list;
34
+
unknown: Jsont.json;
33
35
}
34
36
35
-
(** Parse a single video from PeerTube JSON *)
36
-
val parse_video : Ezjsonm.value -> video
37
+
(** Accessor functions for video *)
38
+
val video_id : video -> int
39
+
val video_uuid : video -> string
40
+
val video_name : video -> string
41
+
val video_description : video -> string option
42
+
val video_url : video -> string
43
+
val video_embed_path : video -> string
44
+
val video_published_at : video -> Ptime.t
45
+
val video_originally_published_at : video -> Ptime.t option
46
+
val video_thumbnail_path : video -> string option
47
+
val video_tags : video -> string list option
48
+
val video_unknown : video -> Jsont.json
37
49
38
-
(** Parse a PeerTube video response *)
39
-
val parse_video_response : Ezjsonm.value -> video_response
50
+
(** Accessor functions for video_response *)
51
+
val video_response_total : video_response -> int
52
+
val video_response_data : video_response -> video list
53
+
val video_response_unknown : video_response -> Jsont.json
54
+
55
+
(** RFC3339 timestamp handling *)
56
+
module Rfc3339 : sig
57
+
val parse : string -> Ptime.t option
58
+
val format : Ptime.t -> string
59
+
val pp : Format.formatter -> Ptime.t -> unit
60
+
val jsont : Ptime.t Jsont.t
61
+
end
62
+
63
+
(** Parse a single video from JSON string *)
64
+
val parse_video_string : string -> video
65
+
66
+
(** Parse a PeerTube video response from JSON string *)
67
+
val parse_video_response_string : string -> video_response
40
68
41
69
(** Fetch videos from a PeerTube instance channel with pagination support
42
70
@param client The PeerTube client
-1
stack/peertubee/peertubee.opam
-1
stack/peertubee/peertubee.opam
+1
-1
stack/requests/bin/dune
+1
-1
stack/requests/bin/dune
+12
-3
stack/requests/bin/ocurl.ml
+12
-3
stack/requests/bin/ocurl.ml
···
191
191
if String.length body_str > 0 &&
192
192
(body_str.[0] = '{' || body_str.[0] = '[') then
193
193
try
194
-
let json = Yojson.Safe.from_string body_str in
195
-
if not quiet then Fmt.pr "[%s]:@." url_str;
196
-
Fmt.pr "%a@." (Yojson.Safe.pretty_print ~std:true) json
194
+
match Jsont_bytesrw.decode_string' Jsont.json body_str with
195
+
| Ok json ->
196
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Jsont.json json with
197
+
| Ok pretty ->
198
+
if not quiet then Fmt.pr "[%s]:@." url_str;
199
+
print_string pretty
200
+
| Error _ ->
201
+
if not quiet then Fmt.pr "[%s]:@." url_str;
202
+
print_string body_str)
203
+
| Error _ ->
204
+
if not quiet then Fmt.pr "[%s]:@." url_str;
205
+
print_string body_str
197
206
with _ ->
198
207
if not quiet then Fmt.pr "[%s]:@." url_str;
199
208
print_string body_str
-1
stack/requests/dune-project
-1
stack/requests/dune-project
+28
-150
stack/requests/lib/body.ml
+28
-150
stack/requests/lib/body.ml
···
43
43
(Eio.Path.native_exn file) (Mime.to_string mime));
44
44
File { file; mime }
45
45
46
-
type json =
47
-
[ `Null | `Bool of bool | `Float of float | `String of string
48
-
| `A of json list | `O of (string * json) list ]
49
-
50
-
let json json_value =
51
-
(* Encode json value to a JSON string *)
52
-
let buffer = Buffer.create 1024 in
53
-
let encoder = Jsonm.encoder ~minify:true (`Buffer buffer) in
54
-
55
-
let enc e l =
56
-
match Jsonm.encode e (`Lexeme l) with
57
-
| `Ok -> ()
58
-
| `Partial -> failwith "Unexpected partial with buffer destination"
46
+
(* For simple JSON encoding, we just take a Jsont.json value and encode it *)
47
+
let json (json_value : Jsont.json) =
48
+
let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with
49
+
| Ok s -> s
50
+
| Error e ->
51
+
let msg = Jsont.Error.to_string e in
52
+
failwith (Printf.sprintf "Failed to encode JSON: %s" msg)
59
53
in
54
+
String { content; mime = Mime.json }
60
55
61
-
let rec encode_value v k e =
62
-
match v with
63
-
| `A vs -> encode_array vs k e
64
-
| `O ms -> encode_object ms k e
65
-
| `Null | `Bool _ | `Float _ | `String _ as v -> enc e v; k e
66
-
and encode_array vs k e =
67
-
enc e `As;
68
-
encode_array_values vs k e
69
-
and encode_array_values vs k e =
70
-
match vs with
71
-
| v :: vs' -> encode_value v (encode_array_values vs' k) e
72
-
| [] -> enc e `Ae; k e
73
-
and encode_object ms k e =
74
-
enc e `Os;
75
-
encode_object_members ms k e
76
-
and encode_object_members ms k e =
77
-
match ms with
78
-
| (n, v) :: ms' ->
79
-
enc e (`Name n);
80
-
encode_value v (encode_object_members ms' k) e
81
-
| [] -> enc e `Oe; k e
82
-
in
83
-
84
-
let finish e =
85
-
match Jsonm.encode e `End with
86
-
| `Ok -> ()
87
-
| `Partial -> failwith "Unexpected partial at end"
88
-
in
89
-
90
-
encode_value json_value finish encoder;
91
-
92
-
String { content = Buffer.contents buffer; mime = Mime.json }
93
-
56
+
(* JSON streaming using jsont - we encode the value to string and stream it *)
94
57
module Json_stream_source = struct
95
-
type encode_state =
96
-
| Ready (* Ready to encode new lexemes *)
97
-
| NeedAwait (* Need to send `Await after previous `Partial *)
98
-
| Finished (* All done *)
99
-
100
58
type t = {
101
-
encoder : Jsonm.encoder;
102
-
mutable buffer : bytes;
103
-
mutable buffer_offset : int;
104
-
mutable buffer_len : int;
105
-
mutable pending_lexemes : Jsonm.lexeme Queue.t;
106
-
mutable encode_state : encode_state;
107
-
mutable end_signaled : bool;
108
-
writer : (Jsonm.lexeme -> unit) -> unit;
59
+
mutable content : string;
60
+
mutable offset : int;
109
61
}
110
62
111
-
let rec single_read t dst =
112
-
if t.encode_state = Finished && t.buffer_offset >= t.buffer_len then
63
+
let single_read t dst =
64
+
if t.offset >= String.length t.content then
113
65
raise End_of_file
114
-
else if t.buffer_offset < t.buffer_len then begin
115
-
(* We have data in buffer to copy *)
116
-
let available = t.buffer_len - t.buffer_offset in
66
+
else begin
67
+
let available = String.length t.content - t.offset in
117
68
let to_copy = min (Cstruct.length dst) available in
118
-
Cstruct.blit_from_bytes t.buffer t.buffer_offset dst 0 to_copy;
119
-
t.buffer_offset <- t.buffer_offset + to_copy;
69
+
Cstruct.blit_from_string t.content t.offset dst 0 to_copy;
70
+
t.offset <- t.offset + to_copy;
120
71
to_copy
121
-
end else begin
122
-
(* Buffer empty, need to generate more data *)
123
-
t.buffer_offset <- 0;
124
-
t.buffer_len <- 0;
125
-
Jsonm.Manual.dst t.encoder t.buffer 0 (Bytes.length t.buffer);
126
-
127
-
let rec process_encoding () =
128
-
match t.encode_state with
129
-
| NeedAwait ->
130
-
(* Send `Await after previous `Partial *)
131
-
(match Jsonm.encode t.encoder `Await with
132
-
| `Ok ->
133
-
t.encode_state <- Ready;
134
-
process_encoding ()
135
-
| `Partial ->
136
-
t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)
137
-
| Ready when not (Queue.is_empty t.pending_lexemes) ->
138
-
(* Encode next lexeme *)
139
-
let lexeme = Queue.take t.pending_lexemes in
140
-
(match Jsonm.encode t.encoder (`Lexeme lexeme) with
141
-
| `Ok ->
142
-
(* Successfully encoded, continue with next *)
143
-
process_encoding ()
144
-
| `Partial ->
145
-
(* Buffer full, need to flush and await
146
-
Note: The lexeme is partially encoded in the encoder's internal state,
147
-
we don't need to re-queue it. After `Await, the encoder continues. *)
148
-
t.encode_state <- NeedAwait;
149
-
t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)
150
-
| Ready when Queue.is_empty t.pending_lexemes && not t.end_signaled ->
151
-
(* All lexemes done, signal end *)
152
-
t.end_signaled <- true;
153
-
(match Jsonm.encode t.encoder `End with
154
-
| `Ok ->
155
-
t.encode_state <- Finished;
156
-
t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder
157
-
| `Partial ->
158
-
t.encode_state <- NeedAwait;
159
-
t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)
160
-
| Ready when t.end_signaled ->
161
-
(* Continue trying to finish *)
162
-
(match Jsonm.encode t.encoder `End with
163
-
| `Ok ->
164
-
t.encode_state <- Finished;
165
-
t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder
166
-
| `Partial ->
167
-
t.encode_state <- NeedAwait;
168
-
t.buffer_len <- Bytes.length t.buffer - Jsonm.Manual.dst_rem t.encoder)
169
-
| Finished ->
170
-
(* All done *)
171
-
()
172
-
| _ -> ()
173
-
in
174
-
process_encoding ();
175
-
176
-
if t.buffer_len > 0 then
177
-
single_read t dst
178
-
else if t.encode_state = Finished then
179
-
raise End_of_file
180
-
else
181
-
(* This shouldn't happen - we should always produce some data or be finished *)
182
-
raise End_of_file
183
72
end
184
73
185
74
let read_methods = []
186
75
end
187
76
188
-
let json_stream_source_create writer =
189
-
let buffer_size = 4096 in
190
-
let buffer = Bytes.create buffer_size in
191
-
let encoder = Jsonm.encoder ~minify:true (`Manual) in
192
-
let pending_lexemes = Queue.create () in
193
-
194
-
(* Call the writer to populate the queue *)
195
-
let encode_lexeme lexeme = Queue.add lexeme pending_lexemes in
196
-
writer encode_lexeme;
197
-
198
-
let t = {
199
-
Json_stream_source.encoder;
200
-
buffer;
201
-
buffer_offset = 0;
202
-
buffer_len = 0;
203
-
pending_lexemes;
204
-
encode_state = Ready;
205
-
end_signaled = false;
206
-
writer;
207
-
} in
77
+
let json_stream_source_create json_value =
78
+
(* Encode the entire JSON value to string with minified format *)
79
+
let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with
80
+
| Ok s -> s
81
+
| Error e ->
82
+
let msg = Jsont.Error.to_string e in
83
+
failwith (Printf.sprintf "Failed to encode JSON stream: %s" msg)
84
+
in
85
+
let t = { Json_stream_source.content; offset = 0 } in
208
86
let ops = Eio.Flow.Pi.source (module Json_stream_source) in
209
87
Eio.Resource.T (t, ops)
210
88
211
-
let json_stream writer =
212
-
let source = json_stream_source_create writer in
89
+
let json_stream json_value =
90
+
let source = json_stream_source_create json_value in
213
91
Stream { source; mime = Mime.json; length = None }
214
92
215
93
let text content =
+14
-31
stack/requests/lib/body.mli
+14
-31
stack/requests/lib/body.mli
···
58
58
59
59
(** {1 Convenience Constructors} *)
60
60
61
-
type json =
62
-
[ `Null | `Bool of bool | `Float of float | `String of string
63
-
| `A of json list | `O of (string * json) list ]
64
-
(** JSON value representation, compatible with Jsonm's json type. *)
65
-
66
-
val json : json -> t
67
-
(** [json value] creates a JSON body from a json value.
61
+
val json : Jsont.json -> t
62
+
(** [json value] creates a JSON body from a Jsont.json value.
68
63
The value is encoded to a JSON string with Content-Type: application/json.
69
64
70
65
Example:
71
66
{[
72
-
let body = Body.json (`O [
73
-
("status", `String "success");
74
-
("count", `Float 42.);
75
-
("items", `A [`String "first"; `String "second"])
76
-
])
67
+
let body = Body.json (Jsont.Object ([
68
+
("status", Jsont.String "success");
69
+
("count", Jsont.Number 42.);
70
+
("items", Jsont.Array ([Jsont.String "first"; Jsont.String "second"], Jsont.Meta.none))
71
+
], Jsont.Meta.none))
77
72
]}
78
73
*)
79
74
80
-
val json_stream : ((Jsonm.lexeme -> unit) -> unit) -> t
81
-
(** [json_stream writer] creates a streaming JSON body using jsonm.
82
-
The [writer] function is called with a callback that accepts jsonm lexemes
83
-
to encode. The body will be streamed as the lexemes are produced.
75
+
val json_stream : Jsont.json -> t
76
+
(** [json_stream json_value] creates a streaming JSON body from a Jsont.json value.
77
+
The JSON value will be encoded to a minified JSON string and streamed.
84
78
85
79
Example:
86
80
{[
87
-
let body = Body.json_stream (fun encode ->
88
-
encode `Os; (* Start object *)
89
-
encode (`Name "users");
90
-
encode `As; (* Start array *)
91
-
List.iter (fun user ->
92
-
encode `Os;
93
-
encode (`Name "id");
94
-
encode (`Float (float_of_int user.id));
95
-
encode (`Name "name");
96
-
encode (`String user.name);
97
-
encode `Oe (* End object *)
98
-
) users;
99
-
encode `Ae; (* End array *)
100
-
encode `Oe (* End object *)
101
-
)
81
+
let large_data = Jsont.Object ([
82
+
("users", Jsont.Array ([...], Jsont.Meta.none))
83
+
], Jsont.Meta.none) in
84
+
let body = Body.json_stream large_data
102
85
]}
103
86
*)
104
87
+98
-30
stack/requests/lib/cache.ml
+98
-30
stack/requests/lib/cache.ml
···
78
78
) parts
79
79
| None -> None
80
80
81
+
(* JSON codec for cache metadata *)
82
+
module Metadata = struct
83
+
type t = {
84
+
status_code : int;
85
+
headers : (string * string) list;
86
+
}
87
+
88
+
let make status_code headers = { status_code; headers }
89
+
let status_code t = t.status_code
90
+
let headers t = t.headers
91
+
92
+
let t_jsont =
93
+
let header_pair_jsont =
94
+
let dec x y = (x, y) in
95
+
let enc (x, y) i = if i = 0 then x else y in
96
+
Jsont.t2 ~dec ~enc Jsont.string
97
+
in
98
+
Jsont.Object.map ~kind:"CacheMetadata" make
99
+
|> Jsont.Object.mem "status_code" Jsont.int ~enc:status_code
100
+
|> Jsont.Object.mem "headers" (Jsont.list header_pair_jsont) ~enc:headers
101
+
|> Jsont.Object.finish
102
+
end
103
+
81
104
let serialize_metadata ~status ~headers =
82
105
let status_code = Cohttp.Code.code_of_status status in
83
106
let headers_assoc = Cohttp.Header.to_list headers in
84
-
let json = `Assoc [
85
-
("status_code", `Int status_code);
86
-
("headers", `Assoc (List.map (fun (k, v) -> (k, `String v)) headers_assoc));
87
-
] in
88
-
Yojson.Basic.to_string json
107
+
let metadata = Metadata.make status_code headers_assoc in
108
+
match Jsont_bytesrw.encode_string' Metadata.t_jsont metadata with
109
+
| Ok s -> s
110
+
| Error e -> failwith (Fmt.str "Failed to serialize metadata: %s" (Jsont.Error.to_string e))
89
111
90
112
let deserialize_metadata json_str =
91
113
try
92
-
let open Yojson.Basic.Util in
93
-
let json = Yojson.Basic.from_string json_str in
94
-
let status_code = json |> member "status_code" |> to_int in
95
-
let status = Cohttp.Code.status_of_code status_code in
96
-
let headers_json = json |> member "headers" |> to_assoc in
97
-
let headers = headers_json
98
-
|> List.map (fun (k, v) -> (k, to_string v))
99
-
|> Cohttp.Header.of_list in
100
-
Some (status, headers)
114
+
match Jsont_bytesrw.decode_string' Metadata.t_jsont json_str with
115
+
| Ok metadata ->
116
+
let status = Cohttp.Code.status_of_code (Metadata.status_code metadata) in
117
+
let headers = Cohttp.Header.of_list (Metadata.headers metadata) in
118
+
Some (status, headers)
119
+
| Error _ -> None
101
120
with _ -> None
102
121
103
122
let get t ~method_ ~url ~headers =
···
396
415
| None -> ());
397
416
Hashtbl.clear t.memory_cache
398
417
418
+
module Stats = struct
419
+
type cacheio_stats = {
420
+
total_entries : int;
421
+
total_bytes : int;
422
+
expired_entries : int;
423
+
pinned_entries : int;
424
+
temporary_entries : int;
425
+
}
426
+
427
+
type t = {
428
+
memory_cache_entries : int;
429
+
cache_backend : string;
430
+
enabled : bool;
431
+
cache_get_requests : bool;
432
+
cache_range_requests : bool;
433
+
cacheio_stats : cacheio_stats option;
434
+
}
435
+
436
+
let make_cacheio_stats total_entries total_bytes expired_entries pinned_entries temporary_entries =
437
+
{ total_entries; total_bytes; expired_entries; pinned_entries; temporary_entries }
438
+
439
+
let make memory_cache_entries cache_backend enabled cache_get_requests cache_range_requests cacheio_stats =
440
+
{ memory_cache_entries; cache_backend; enabled; cache_get_requests; cache_range_requests; cacheio_stats }
441
+
442
+
let cacheio_stats_jsont =
443
+
Jsont.Object.map ~kind:"CacheioStats" make_cacheio_stats
444
+
|> Jsont.Object.mem "total_entries" Jsont.int ~enc:(fun t -> t.total_entries)
445
+
|> Jsont.Object.mem "total_bytes" Jsont.int ~enc:(fun t -> t.total_bytes)
446
+
|> Jsont.Object.mem "expired_entries" Jsont.int ~enc:(fun t -> t.expired_entries)
447
+
|> Jsont.Object.mem "pinned_entries" Jsont.int ~enc:(fun t -> t.pinned_entries)
448
+
|> Jsont.Object.mem "temporary_entries" Jsont.int ~enc:(fun t -> t.temporary_entries)
449
+
|> Jsont.Object.finish
450
+
451
+
let t_jsont =
452
+
Jsont.Object.map ~kind:"CacheStats" make
453
+
|> Jsont.Object.mem "memory_cache_entries" Jsont.int ~enc:(fun t -> t.memory_cache_entries)
454
+
|> Jsont.Object.mem "cache_backend" Jsont.string ~enc:(fun t -> t.cache_backend)
455
+
|> Jsont.Object.mem "enabled" Jsont.bool ~enc:(fun t -> t.enabled)
456
+
|> Jsont.Object.mem "cache_get_requests" Jsont.bool ~enc:(fun t -> t.cache_get_requests)
457
+
|> Jsont.Object.mem "cache_range_requests" Jsont.bool ~enc:(fun t -> t.cache_range_requests)
458
+
|> Jsont.Object.opt_mem "cacheio_stats" cacheio_stats_jsont ~enc:(fun t -> t.cacheio_stats)
459
+
|> Jsont.Object.finish
460
+
461
+
let to_string t =
462
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent t_jsont t with
463
+
| Ok s -> s
464
+
| Error e ->
465
+
let msg = Jsont.Error.to_string e in
466
+
failwith (Printf.sprintf "Failed to encode stats: %s" msg)
467
+
end
468
+
399
469
let stats t =
400
470
let cacheio_stats =
401
471
match t.cacheio with
402
472
| Some cache ->
403
473
let stats = Cacheio.stats cache in
404
-
`Assoc [
405
-
("total_entries", `Int (Cacheio.Stats.entry_count stats));
406
-
("total_bytes", `Int (Int64.to_int (Cacheio.Stats.total_size stats)));
407
-
("expired_entries", `Int (Cacheio.Stats.expired_count stats));
408
-
("pinned_entries", `Int (Cacheio.Stats.pinned_count stats));
409
-
("temporary_entries", `Int (Cacheio.Stats.temporary_count stats));
410
-
]
411
-
| None -> `Assoc []
474
+
Some (Stats.make_cacheio_stats
475
+
(Cacheio.Stats.entry_count stats)
476
+
(Int64.to_int (Cacheio.Stats.total_size stats))
477
+
(Cacheio.Stats.expired_count stats)
478
+
(Cacheio.Stats.pinned_count stats)
479
+
(Cacheio.Stats.temporary_count stats))
480
+
| None -> None
412
481
in
413
-
`Assoc [
414
-
("memory_cache_entries", `Int (Hashtbl.length t.memory_cache));
415
-
("cache_backend", `String (if Option.is_some t.cacheio then "cacheio" else "memory"));
416
-
("enabled", `Bool t.enabled);
417
-
("cache_get_requests", `Bool t.cache_get_requests);
418
-
("cache_range_requests", `Bool t.cache_range_requests);
419
-
("cacheio_stats", cacheio_stats);
420
-
]
482
+
Stats.make
483
+
(Hashtbl.length t.memory_cache)
484
+
(if Option.is_some t.cacheio then "cacheio" else "memory")
485
+
t.enabled
486
+
t.cache_get_requests
487
+
t.cache_range_requests
488
+
cacheio_stats
+2
-3
stack/requests/lib/dune
+2
-3
stack/requests/lib/dune
-1
stack/requests/requests.opam
-1
stack/requests/requests.opam
-18
stack/requests/test/dune
-18
stack/requests/test/dune
···
1
-
(test
2
-
(name test_requests)
3
-
(libraries
4
-
requests
5
-
alcotest
6
-
eio
7
-
eio_main
8
-
cohttp
9
-
cohttp-eio
10
-
uri
11
-
yojson
12
-
logs
13
-
str)
14
-
(deps
15
-
(package requests)))(executable
16
-
(name test_connection_pool)
17
-
(modules test_connection_pool)
18
-
(libraries requests eio_main logs logs.fmt conpool))
-52
stack/requests/test/test_connection_pool.ml
-52
stack/requests/test/test_connection_pool.ml
···
1
-
(** Test stateless One API - each request opens a fresh connection *)
2
-
3
-
open Eio.Std
4
-
5
-
let test_one_stateless () =
6
-
(* Initialize RNG for TLS *)
7
-
Mirage_crypto_rng_unix.use_default ();
8
-
9
-
Eio_main.run @@ fun env ->
10
-
Switch.run @@ fun sw ->
11
-
12
-
(* Configure logging to see One request activity *)
13
-
Logs.set_reporter (Logs_fmt.reporter ());
14
-
Logs.set_level (Some Logs.Info);
15
-
Logs.Src.set_level Requests.One.src (Some Logs.Info);
16
-
17
-
traceln "=== Testing One Stateless API ===\n";
18
-
traceln "The One API creates fresh connections for each request (no pooling)\n";
19
-
20
-
(* Make multiple requests to the same host using stateless One API *)
21
-
let start_time = Unix.gettimeofday () in
22
-
23
-
for i = 1 to 10 do
24
-
traceln "Request %d:" i;
25
-
let response = Requests.One.get ~sw
26
-
~clock:env#clock ~net:env#net
27
-
"http://example.com"
28
-
in
29
-
30
-
traceln " Status: %d" (Requests.Response.status_code response);
31
-
traceln " Content-Length: %s"
32
-
(match Requests.Response.content_length response with
33
-
| Some len -> Int64.to_string len
34
-
| None -> "unknown");
35
-
36
-
(* Connection is fresh for each request - no pooling *)
37
-
traceln ""
38
-
done;
39
-
40
-
let elapsed = Unix.gettimeofday () -. start_time in
41
-
traceln "All 10 requests completed in %.2f seconds" elapsed;
42
-
traceln "Average: %.2f seconds per request" (elapsed /. 10.0);
43
-
44
-
traceln "\n=== Test completed successfully ==="
45
-
46
-
let () =
47
-
try
48
-
test_one_stateless ()
49
-
with e ->
50
-
traceln "Test failed with exception: %s" (Printexc.to_string e);
51
-
Printexc.print_backtrace stdout;
52
-
exit 1
-899
stack/requests/test/test_requests.ml
-899
stack/requests/test/test_requests.ml
···
1
-
open Eio_main
2
-
3
-
let port = ref 8088
4
-
5
-
let get_free_port () =
6
-
let p = !port in
7
-
incr port;
8
-
p
9
-
10
-
let string_contains s sub =
11
-
try
12
-
let _ = Str.search_forward (Str.regexp_string sub) s 0 in
13
-
true
14
-
with Not_found -> false
15
-
16
-
module Test_server = struct
17
-
open Cohttp_eio
18
-
19
-
let make_server ~port handler env =
20
-
let server_socket =
21
-
Eio.Net.listen env#net ~sw:env#sw ~backlog:128 ~reuse_addr:true
22
-
(`Tcp (Eio.Net.Ipaddr.V4.loopback, port))
23
-
in
24
-
let callback _conn req body =
25
-
let (resp, body_content) = handler ~request:req ~body in
26
-
Server.respond_string () ~status:(Http.Response.status resp)
27
-
~headers:(Http.Response.headers resp)
28
-
~body:body_content
29
-
in
30
-
let server = Server.make ~callback () in
31
-
Server.run server_socket server ~on_error:(fun exn ->
32
-
Logs.err (fun m -> m "Server error: %s" (Printexc.to_string exn))
33
-
)
34
-
35
-
let echo_handler ~request ~body =
36
-
let uri = Http.Request.resource request in
37
-
let meth = Http.Request.meth request in
38
-
let headers = Http.Request.headers request in
39
-
let body_str = Eio.Flow.read_all body in
40
-
41
-
let response_body =
42
-
`Assoc [
43
-
"method", `String (Cohttp.Code.string_of_method meth);
44
-
"uri", `String uri;
45
-
"headers", `Assoc (
46
-
Cohttp.Header.to_lines headers
47
-
|> List.map (fun line ->
48
-
match String.split_on_char ':' line with
49
-
| [k; v] -> (String.trim k, `String (String.trim v))
50
-
| _ -> ("", `String line)
51
-
)
52
-
);
53
-
"body", `String body_str;
54
-
]
55
-
|> Yojson.Basic.to_string
56
-
in
57
-
58
-
let resp = Http.Response.make ~status:`OK () in
59
-
let resp_headers = Cohttp.Header.add_unless_exists
60
-
(Http.Response.headers resp) "content-type" "application/json"
61
-
in
62
-
({ resp with headers = resp_headers }, response_body)
63
-
64
-
let status_handler status_code ~request:_ ~body:_ =
65
-
let status = Cohttp.Code.status_of_code status_code in
66
-
let resp = Http.Response.make ~status () in
67
-
(resp, "")
68
-
69
-
let redirect_handler target_path ~request:_ ~body:_ =
70
-
let resp = Http.Response.make ~status:`Moved_permanently () in
71
-
let headers = Cohttp.Header.add
72
-
(Http.Response.headers resp) "location" target_path
73
-
in
74
-
({ resp with headers }, "")
75
-
76
-
let cookie_handler ~request ~body:_ =
77
-
let headers = Http.Request.headers request in
78
-
let cookies =
79
-
match Cohttp.Header.get headers "cookie" with
80
-
| Some cookie_str -> cookie_str
81
-
| None -> "no cookies"
82
-
in
83
-
84
-
let resp = Http.Response.make ~status:`OK () in
85
-
let resp_headers =
86
-
Http.Response.headers resp
87
-
|> (fun h -> Cohttp.Header.add h "set-cookie" "test_cookie=test_value; Path=/")
88
-
|> (fun h -> Cohttp.Header.add h "set-cookie" "session=abc123; Path=/; HttpOnly")
89
-
in
90
-
({ resp with headers = resp_headers },
91
-
cookies)
92
-
93
-
let auth_handler ~request ~body:_ =
94
-
let headers = Http.Request.headers request in
95
-
let auth_result =
96
-
match Cohttp.Header.get headers "authorization" with
97
-
| Some auth ->
98
-
if String.starts_with ~prefix:"Bearer " auth then
99
-
let token = String.sub auth 7 (String.length auth - 7) in
100
-
if token = "valid_token" then "authorized"
101
-
else "invalid token"
102
-
else if String.starts_with ~prefix:"Basic " auth then
103
-
"basic auth received"
104
-
else "unknown auth"
105
-
| None -> "no auth"
106
-
in
107
-
108
-
let status =
109
-
if auth_result = "authorized" || auth_result = "basic auth received"
110
-
then `OK
111
-
else `Unauthorized
112
-
in
113
-
let resp = Http.Response.make ~status () in
114
-
(resp, auth_result)
115
-
116
-
let json_handler ~request:_ ~body =
117
-
let body_str = Eio.Flow.read_all body in
118
-
let json =
119
-
try
120
-
let parsed = Yojson.Basic.from_string body_str in
121
-
`Assoc [
122
-
"received", parsed;
123
-
"echo", `Bool true;
124
-
]
125
-
with _ ->
126
-
`Assoc [
127
-
"error", `String "invalid json";
128
-
"received", `String body_str;
129
-
]
130
-
in
131
-
132
-
let resp = Http.Response.make ~status:`OK () in
133
-
let resp_headers = Cohttp.Header.add_unless_exists
134
-
(Http.Response.headers resp) "content-type" "application/json"
135
-
in
136
-
({ resp with headers = resp_headers },
137
-
Yojson.Basic.to_string json)
138
-
139
-
let timeout_handler clock delay ~request:_ ~body:_ =
140
-
Eio.Time.sleep clock delay;
141
-
let resp = Http.Response.make ~status:`OK () in
142
-
(resp,"delayed response")
143
-
144
-
let chunked_handler _clock chunks ~request:_ ~body:_ =
145
-
let resp = Http.Response.make ~status:`OK () in
146
-
let body_str = String.concat "" chunks in
147
-
(resp,body_str)
148
-
149
-
let large_response_handler size ~request:_ ~body:_ =
150
-
let data = String.make size 'X' in
151
-
let resp = Http.Response.make ~status:`OK () in
152
-
(resp,data)
153
-
154
-
let multipart_handler ~request ~body =
155
-
let headers = Http.Request.headers request in
156
-
let content_type = Cohttp.Header.get headers "content-type" in
157
-
let body_str = Eio.Flow.read_all body in
158
-
159
-
let result =
160
-
match content_type with
161
-
| Some ct when String.starts_with ~prefix:"multipart/form-data" ct ->
162
-
Printf.sprintf "Multipart received: %d bytes" (String.length body_str)
163
-
| _ -> "Not multipart"
164
-
in
165
-
166
-
let resp = Http.Response.make ~status:`OK () in
167
-
(resp,result)
168
-
169
-
let router clock ~request ~body =
170
-
let uri = Http.Request.resource request in
171
-
match uri with
172
-
| "/" | "/echo" -> echo_handler ~request ~body
173
-
| "/status/200" -> status_handler 200 ~request ~body
174
-
| "/status/404" -> status_handler 404 ~request ~body
175
-
| "/status/500" -> status_handler 500 ~request ~body
176
-
| "/redirect" -> redirect_handler "/redirected" ~request ~body
177
-
| "/redirected" ->
178
-
let resp = Http.Response.make ~status:`OK () in
179
-
(resp,"redirect successful")
180
-
| "/cookies" -> cookie_handler ~request ~body
181
-
| "/auth" -> auth_handler ~request ~body
182
-
| "/json" -> json_handler ~request ~body
183
-
| "/timeout" -> timeout_handler clock 2.0 ~request ~body
184
-
| "/chunked" ->
185
-
chunked_handler clock ["chunk1"; "chunk2"; "chunk3"] ~request ~body
186
-
| "/large" -> large_response_handler 10000 ~request ~body
187
-
| "/multipart" -> multipart_handler ~request ~body
188
-
| _ -> status_handler 404 ~request ~body
189
-
190
-
let start_server ~port env =
191
-
Eio.Fiber.fork ~sw:env#sw (fun () ->
192
-
make_server ~port (router env#clock) env
193
-
);
194
-
Eio.Time.sleep env#clock 0.1
195
-
end
196
-
197
-
let test_get_request () =
198
-
run @@ fun env ->
199
-
Eio.Switch.run @@ fun sw ->
200
-
let port = get_free_port () in
201
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
202
-
203
-
let test_env = object
204
-
method clock = env#clock
205
-
method net = env#net
206
-
method sw = sw
207
-
end in
208
-
Test_server.start_server ~port test_env;
209
-
210
-
let req = Requests.create ~sw env in
211
-
let response = Requests.get req (base_url ^ "/echo") in
212
-
213
-
Alcotest.(check int) "GET status" 200 (Requests.Response.status_code response);
214
-
215
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
216
-
let json = Yojson.Basic.from_string body_str in
217
-
let method_str =
218
-
json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string
219
-
in
220
-
221
-
Alcotest.(check string) "GET method" "GET" method_str
222
-
223
-
let test_post_request () =
224
-
run @@ fun env ->
225
-
Eio.Switch.run @@ fun sw ->
226
-
let port = get_free_port () in
227
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
228
-
229
-
let test_env = object
230
-
method clock = env#clock
231
-
method net = env#net
232
-
method sw = sw
233
-
end in
234
-
Test_server.start_server ~port test_env;
235
-
236
-
let req = Requests.create ~sw env in
237
-
let body = Requests.Body.text "test post data" in
238
-
let response = Requests.post req ~body (base_url ^ "/echo") in
239
-
240
-
Alcotest.(check int) "POST status" 200 (Requests.Response.status_code response);
241
-
242
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
243
-
let json = Yojson.Basic.from_string body_str in
244
-
let received_body =
245
-
json |> Yojson.Basic.Util.member "body" |> Yojson.Basic.Util.to_string
246
-
in
247
-
248
-
Alcotest.(check string) "POST body" "test post data" received_body
249
-
250
-
let test_put_request () =
251
-
run @@ fun env ->
252
-
Eio.Switch.run @@ fun sw ->
253
-
let port = get_free_port () in
254
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
255
-
256
-
let test_env = object
257
-
method clock = env#clock
258
-
method net = env#net
259
-
method sw = sw
260
-
end in
261
-
Test_server.start_server ~port test_env;
262
-
263
-
let req = Requests.create ~sw env in
264
-
let body = Requests.Body.text "put data" in
265
-
let response = Requests.put req ~body (base_url ^ "/echo") in
266
-
267
-
Alcotest.(check int) "PUT status" 200 (Requests.Response.status_code response);
268
-
269
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
270
-
let json = Yojson.Basic.from_string body_str in
271
-
let method_str =
272
-
json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string
273
-
in
274
-
275
-
Alcotest.(check string) "PUT method" "PUT" method_str
276
-
277
-
let test_delete_request () =
278
-
run @@ fun env ->
279
-
Eio.Switch.run @@ fun sw ->
280
-
let port = get_free_port () in
281
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
282
-
283
-
let test_env = object
284
-
method clock = env#clock
285
-
method net = env#net
286
-
method sw = sw
287
-
end in
288
-
Test_server.start_server ~port test_env;
289
-
290
-
let req = Requests.create ~sw env in
291
-
let response = Requests.delete req (base_url ^ "/echo") in
292
-
293
-
Alcotest.(check int) "DELETE status" 200 (Requests.Response.status_code response);
294
-
295
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
296
-
let json = Yojson.Basic.from_string body_str in
297
-
let method_str =
298
-
json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string
299
-
in
300
-
301
-
Alcotest.(check string) "DELETE method" "DELETE" method_str
302
-
303
-
let test_patch_request () =
304
-
run @@ fun env ->
305
-
Eio.Switch.run @@ fun sw ->
306
-
let port = get_free_port () in
307
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
308
-
309
-
let test_env = object
310
-
method clock = env#clock
311
-
method net = env#net
312
-
method sw = sw
313
-
end in
314
-
Test_server.start_server ~port test_env;
315
-
316
-
let req = Requests.create ~sw env in
317
-
let body = Requests.Body.of_string Requests.Mime.json {|{"patch": "data"}|} in
318
-
let response = Requests.patch req ~body (base_url ^ "/echo") in
319
-
320
-
Alcotest.(check int) "PATCH status" 200 (Requests.Response.status_code response);
321
-
322
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
323
-
let json = Yojson.Basic.from_string body_str in
324
-
let method_str =
325
-
json |> Yojson.Basic.Util.member "method" |> Yojson.Basic.Util.to_string
326
-
in
327
-
328
-
Alcotest.(check string) "PATCH method" "PATCH" method_str
329
-
330
-
let test_head_request () =
331
-
run @@ fun env ->
332
-
Eio.Switch.run @@ fun sw ->
333
-
let port = get_free_port () in
334
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
335
-
336
-
let test_env = object
337
-
method clock = env#clock
338
-
method net = env#net
339
-
method sw = sw
340
-
end in
341
-
Test_server.start_server ~port test_env;
342
-
343
-
let req = Requests.create ~sw env in
344
-
let response = Requests.head req (base_url ^ "/echo") in
345
-
346
-
Alcotest.(check int) "HEAD status" 200 (Requests.Response.status_code response)
347
-
348
-
let test_options_request () =
349
-
run @@ fun env ->
350
-
Eio.Switch.run @@ fun sw ->
351
-
let port = get_free_port () in
352
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
353
-
354
-
let test_env = object
355
-
method clock = env#clock
356
-
method net = env#net
357
-
method sw = sw
358
-
end in
359
-
Test_server.start_server ~port test_env;
360
-
361
-
let req = Requests.create ~sw env in
362
-
let response = Requests.options req (base_url ^ "/echo") in
363
-
364
-
Alcotest.(check int) "OPTIONS status" 200 (Requests.Response.status_code response)
365
-
366
-
let test_custom_headers () =
367
-
run @@ fun env ->
368
-
Eio.Switch.run @@ fun sw ->
369
-
let port = get_free_port () in
370
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
371
-
372
-
let test_env = object
373
-
method clock = env#clock
374
-
method net = env#net
375
-
method sw = sw
376
-
end in
377
-
Test_server.start_server ~port test_env;
378
-
379
-
let req = Requests.create ~sw env in
380
-
let headers =
381
-
Requests.Headers.empty
382
-
|> Requests.Headers.set "X-Custom-Header" "custom-value"
383
-
|> Requests.Headers.set "User-Agent" "test-agent"
384
-
in
385
-
let response = Requests.get req ~headers (base_url ^ "/echo") in
386
-
387
-
Alcotest.(check int) "Headers status" 200 (Requests.Response.status_code response);
388
-
389
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
390
-
let json = Yojson.Basic.from_string body_str in
391
-
let headers_obj = json |> Yojson.Basic.Util.member "headers" in
392
-
393
-
let custom_header =
394
-
headers_obj
395
-
|> Yojson.Basic.Util.member "x-custom-header"
396
-
|> Yojson.Basic.Util.to_string_option
397
-
|> Option.value ~default:""
398
-
in
399
-
400
-
Alcotest.(check string) "Custom header" "custom-value" custom_header
401
-
402
-
let test_query_params () =
403
-
run @@ fun env ->
404
-
Eio.Switch.run @@ fun sw ->
405
-
let port = get_free_port () in
406
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
407
-
408
-
let test_env = object
409
-
method clock = env#clock
410
-
method net = env#net
411
-
method sw = sw
412
-
end in
413
-
Test_server.start_server ~port test_env;
414
-
415
-
let req = Requests.create ~sw env in
416
-
let params = [("key1", "value1"); ("key2", "value2")] in
417
-
let response = Requests.get req ~params (base_url ^ "/echo") in
418
-
419
-
Alcotest.(check int) "Query params status" 200 (Requests.Response.status_code response);
420
-
421
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
422
-
let json = Yojson.Basic.from_string body_str in
423
-
let uri = json |> Yojson.Basic.Util.member "uri" |> Yojson.Basic.Util.to_string in
424
-
425
-
Alcotest.(check bool) "Query params present" true
426
-
(string_contains uri "key1=value1" && string_contains uri "key2=value2")
427
-
428
-
let test_json_body () =
429
-
run @@ fun env ->
430
-
Eio.Switch.run @@ fun sw ->
431
-
let port = get_free_port () in
432
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
433
-
434
-
let test_env = object
435
-
method clock = env#clock
436
-
method net = env#net
437
-
method sw = sw
438
-
end in
439
-
Test_server.start_server ~port test_env;
440
-
441
-
let req = Requests.create ~sw env in
442
-
let json_data = {|{"name": "test", "value": 42}|} in
443
-
let body = Requests.Body.of_string Requests.Mime.json json_data in
444
-
let response = Requests.post req ~body (base_url ^ "/json") in
445
-
446
-
Alcotest.(check int) "JSON body status" 200 (Requests.Response.status_code response);
447
-
448
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
449
-
let json = Yojson.Basic.from_string body_str in
450
-
let received = json |> Yojson.Basic.Util.member "received" in
451
-
let name = received |> Yojson.Basic.Util.member "name" |> Yojson.Basic.Util.to_string in
452
-
453
-
Alcotest.(check string) "JSON field" "test" name
454
-
455
-
let test_form_data () =
456
-
run @@ fun env ->
457
-
Eio.Switch.run @@ fun sw ->
458
-
let port = get_free_port () in
459
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
460
-
461
-
let test_env = object
462
-
method clock = env#clock
463
-
method net = env#net
464
-
method sw = sw
465
-
end in
466
-
Test_server.start_server ~port test_env;
467
-
468
-
let req = Requests.create ~sw env in
469
-
let form_data = [("field1", "value1"); ("field2", "value2")] in
470
-
let body = Requests.Body.form form_data in
471
-
let response = Requests.post req ~body (base_url ^ "/echo") in
472
-
473
-
Alcotest.(check int) "Form data status" 200 (Requests.Response.status_code response);
474
-
475
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
476
-
let json = Yojson.Basic.from_string body_str in
477
-
let received_body =
478
-
json |> Yojson.Basic.Util.member "body" |> Yojson.Basic.Util.to_string
479
-
in
480
-
481
-
Alcotest.(check bool) "Form data encoded" true
482
-
(string_contains received_body "field1=value1" &&
483
-
string_contains received_body "field2=value2")
484
-
485
-
let test_status_codes () =
486
-
run @@ fun env ->
487
-
Eio.Switch.run @@ fun sw ->
488
-
let port = get_free_port () in
489
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
490
-
491
-
let test_env = object
492
-
method clock = env#clock
493
-
method net = env#net
494
-
method sw = sw
495
-
end in
496
-
Test_server.start_server ~port test_env;
497
-
498
-
let req = Requests.create ~sw env in
499
-
500
-
let resp_200 = Requests.get req (base_url ^ "/status/200") in
501
-
Alcotest.(check int) "Status 200" 200 (Requests.Response.status_code resp_200);
502
-
503
-
let resp_404 = Requests.get req (base_url ^ "/status/404") in
504
-
Alcotest.(check int) "Status 404" 404 (Requests.Response.status_code resp_404);
505
-
506
-
let resp_500 = Requests.get req (base_url ^ "/status/500") in
507
-
Alcotest.(check int) "Status 500" 500 (Requests.Response.status_code resp_500)
508
-
509
-
let test_redirects () =
510
-
run @@ fun env ->
511
-
Eio.Switch.run @@ fun sw ->
512
-
let port = get_free_port () in
513
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
514
-
515
-
let test_env = object
516
-
method clock = env#clock
517
-
method net = env#net
518
-
method sw = sw
519
-
end in
520
-
Test_server.start_server ~port test_env;
521
-
522
-
let req = Requests.create ~sw ~follow_redirects:true env in
523
-
let response = Requests.get req (base_url ^ "/redirect") in
524
-
525
-
Alcotest.(check int) "Redirect followed" 200 (Requests.Response.status_code response);
526
-
527
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
528
-
Alcotest.(check string) "Redirect result" "redirect successful" body_str
529
-
530
-
let test_no_redirect () =
531
-
run @@ fun env ->
532
-
Eio.Switch.run @@ fun sw ->
533
-
let port = get_free_port () in
534
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
535
-
536
-
let test_env = object
537
-
method clock = env#clock
538
-
method net = env#net
539
-
method sw = sw
540
-
end in
541
-
Test_server.start_server ~port test_env;
542
-
543
-
let req = Requests.create ~sw env in
544
-
let response = Requests.request req ~follow_redirects:false ~method_:`GET (base_url ^ "/redirect") in
545
-
546
-
Alcotest.(check int) "Redirect not followed" 301
547
-
(Requests.Response.status_code response)
548
-
549
-
let test_cookies () =
550
-
run @@ fun env ->
551
-
Eio.Switch.run @@ fun sw ->
552
-
let port = get_free_port () in
553
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
554
-
555
-
let test_env = object
556
-
method clock = env#clock
557
-
method net = env#net
558
-
method sw = sw
559
-
end in
560
-
Test_server.start_server ~port test_env;
561
-
562
-
let req = Requests.create ~sw env in
563
-
564
-
let _first_response = Requests.get req (base_url ^ "/cookies") in
565
-
566
-
let second_response = Requests.get req (base_url ^ "/cookies") in
567
-
let body_str = Requests.Response.body second_response |> Eio.Flow.read_all in
568
-
569
-
Alcotest.(check bool) "Cookies sent back" true
570
-
(string_contains body_str "test_cookie=test_value")
571
-
572
-
let test_bearer_auth () =
573
-
run @@ fun env ->
574
-
Eio.Switch.run @@ fun sw ->
575
-
let port = get_free_port () in
576
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
577
-
578
-
let test_env = object
579
-
method clock = env#clock
580
-
method net = env#net
581
-
method sw = sw
582
-
end in
583
-
Test_server.start_server ~port test_env;
584
-
585
-
let req = Requests.create ~sw env in
586
-
let auth = Requests.Auth.bearer ~token:"valid_token" in
587
-
let response = Requests.get req ~auth (base_url ^ "/auth") in
588
-
589
-
Alcotest.(check int) "Bearer auth status" 200 (Requests.Response.status_code response);
590
-
591
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
592
-
Alcotest.(check string) "Bearer auth result" "authorized" body_str
593
-
594
-
let test_basic_auth () =
595
-
run @@ fun env ->
596
-
Eio.Switch.run @@ fun sw ->
597
-
let port = get_free_port () in
598
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
599
-
600
-
let test_env = object
601
-
method clock = env#clock
602
-
method net = env#net
603
-
method sw = sw
604
-
end in
605
-
Test_server.start_server ~port test_env;
606
-
607
-
let req = Requests.create ~sw env in
608
-
let auth = Requests.Auth.basic ~username:"user" ~password:"pass" in
609
-
let response = Requests.get req ~auth (base_url ^ "/auth") in
610
-
611
-
Alcotest.(check int) "Basic auth status" 200 (Requests.Response.status_code response);
612
-
613
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
614
-
Alcotest.(check string) "Basic auth result" "basic auth received" body_str
615
-
616
-
let test_timeout () =
617
-
run @@ fun env ->
618
-
Eio.Switch.run @@ fun sw ->
619
-
let port = get_free_port () in
620
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
621
-
622
-
let test_env = object
623
-
method clock = env#clock
624
-
method net = env#net
625
-
method sw = sw
626
-
end in
627
-
Test_server.start_server ~port test_env;
628
-
629
-
let req = Requests.create ~sw env in
630
-
let timeout = Requests.Timeout.create ~total:0.5 () in
631
-
632
-
let exception_raised =
633
-
try
634
-
let _ = Requests.get req ~timeout (base_url ^ "/timeout") in
635
-
false
636
-
with _ -> true
637
-
in
638
-
639
-
Alcotest.(check bool) "Timeout triggered" true exception_raised
640
-
641
-
let test_concurrent_requests () =
642
-
run @@ fun env ->
643
-
Eio.Switch.run @@ fun sw ->
644
-
let port = get_free_port () in
645
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
646
-
647
-
let test_env = object
648
-
method clock = env#clock
649
-
method net = env#net
650
-
method sw = sw
651
-
end in
652
-
Test_server.start_server ~port test_env;
653
-
654
-
let req = Requests.create ~sw env in
655
-
656
-
let r1 = ref None in
657
-
let r2 = ref None in
658
-
let r3 = ref None in
659
-
660
-
Eio.Fiber.all [
661
-
(fun () -> r1 := Some (Requests.get req (base_url ^ "/status/200")));
662
-
(fun () -> r2 := Some (Requests.get req (base_url ^ "/status/404")));
663
-
(fun () -> r3 := Some (Requests.get req (base_url ^ "/status/500")));
664
-
];
665
-
666
-
let r1 = Option.get !r1 in
667
-
let r2 = Option.get !r2 in
668
-
let r3 = Option.get !r3 in
669
-
670
-
Alcotest.(check int) "Concurrent 1" 200 (Requests.Response.status_code r1);
671
-
Alcotest.(check int) "Concurrent 2" 404 (Requests.Response.status_code r2);
672
-
Alcotest.(check int) "Concurrent 3" 500 (Requests.Response.status_code r3)
673
-
674
-
let test_large_response () =
675
-
run @@ fun env ->
676
-
Eio.Switch.run @@ fun sw ->
677
-
let port = get_free_port () in
678
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
679
-
680
-
let test_env = object
681
-
method clock = env#clock
682
-
method net = env#net
683
-
method sw = sw
684
-
end in
685
-
Test_server.start_server ~port test_env;
686
-
687
-
let req = Requests.create ~sw env in
688
-
let response = Requests.get req (base_url ^ "/large") in
689
-
690
-
Alcotest.(check int) "Large response status" 200 (Requests.Response.status_code response);
691
-
692
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
693
-
Alcotest.(check int) "Large response size" 10000 (String.length body_str)
694
-
695
-
let test_one_module () =
696
-
run @@ fun env ->
697
-
Eio.Switch.run @@ fun sw ->
698
-
let port = get_free_port () in
699
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
700
-
701
-
let test_env = object
702
-
method clock = env#clock
703
-
method net = env#net
704
-
method sw = sw
705
-
end in
706
-
Test_server.start_server ~port test_env;
707
-
708
-
let response = Requests.One.get ~sw
709
-
~clock:env#clock ~net:env#net
710
-
(base_url ^ "/echo")
711
-
in
712
-
713
-
Alcotest.(check int) "One module status" 200 (Requests.Response.status_code response)
714
-
715
-
let test_multipart () =
716
-
run @@ fun env ->
717
-
Eio.Switch.run @@ fun sw ->
718
-
let port = get_free_port () in
719
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
720
-
721
-
let test_env = object
722
-
method clock = env#clock
723
-
method net = env#net
724
-
method sw = sw
725
-
end in
726
-
Test_server.start_server ~port test_env;
727
-
728
-
let req = Requests.create ~sw env in
729
-
let parts = [
730
-
{ Requests.Body.name = "field1";
731
-
filename = None;
732
-
content_type = Requests.Mime.text;
733
-
content = `String "value1" };
734
-
{ Requests.Body.name = "field2";
735
-
filename = Some "test.txt";
736
-
content_type = Requests.Mime.text;
737
-
content = `String "file content" };
738
-
] in
739
-
let body = Requests.Body.multipart parts in
740
-
let response = Requests.post req ~body (base_url ^ "/multipart") in
741
-
742
-
Alcotest.(check int) "Multipart status" 200 (Requests.Response.status_code response);
743
-
744
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
745
-
Alcotest.(check bool) "Multipart recognized" true
746
-
(String.starts_with ~prefix:"Multipart received:" body_str)
747
-
748
-
let test_response_headers () =
749
-
run @@ fun env ->
750
-
Eio.Switch.run @@ fun sw ->
751
-
let port = get_free_port () in
752
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
753
-
754
-
let test_env = object
755
-
method clock = env#clock
756
-
method net = env#net
757
-
method sw = sw
758
-
end in
759
-
Test_server.start_server ~port test_env;
760
-
761
-
let req = Requests.create ~sw env in
762
-
let response = Requests.get req (base_url ^ "/json") in
763
-
764
-
let content_type =
765
-
Requests.Response.headers response
766
-
|> Requests.Headers.get "content-type"
767
-
in
768
-
769
-
Alcotest.(check (option string)) "Response content-type"
770
-
(Some "application/json") content_type
771
-
772
-
let test_default_headers () =
773
-
run @@ fun env ->
774
-
Eio.Switch.run @@ fun sw ->
775
-
let port = get_free_port () in
776
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
777
-
778
-
let test_env = object
779
-
method clock = env#clock
780
-
method net = env#net
781
-
method sw = sw
782
-
end in
783
-
Test_server.start_server ~port test_env;
784
-
785
-
let default_headers =
786
-
Requests.Headers.empty
787
-
|> Requests.Headers.set "X-Default" "default-value"
788
-
in
789
-
let req = Requests.create ~sw ~default_headers env in
790
-
let response = Requests.get req (base_url ^ "/echo") in
791
-
792
-
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
793
-
let json = Yojson.Basic.from_string body_str in
794
-
let headers_obj = json |> Yojson.Basic.Util.member "headers" in
795
-
796
-
let default_header =
797
-
headers_obj
798
-
|> Yojson.Basic.Util.member "x-default"
799
-
|> Yojson.Basic.Util.to_string_option
800
-
|> Option.value ~default:""
801
-
in
802
-
803
-
Alcotest.(check string) "Default header present" "default-value" default_header
804
-
805
-
let test_session_persistence () =
806
-
run @@ fun env ->
807
-
Eio.Switch.run @@ fun sw ->
808
-
let port = get_free_port () in
809
-
let base_url = Printf.sprintf "http://127.0.0.1:%d" port in
810
-
811
-
let test_env = object
812
-
method clock = env#clock
813
-
method net = env#net
814
-
method sw = sw
815
-
end in
816
-
Test_server.start_server ~port test_env;
817
-
818
-
let req = Requests.create ~sw env in
819
-
820
-
let req = Requests.set_default_header req "X-Session" "session-123" in
821
-
822
-
let auth = Requests.Auth.bearer ~token:"test_token" in
823
-
let req = Requests.set_auth req auth in
824
-
825
-
let response1 = Requests.get req (base_url ^ "/echo") in
826
-
let body_str1 = Requests.Response.body response1 |> Eio.Flow.read_all in
827
-
let json1 = Yojson.Basic.from_string body_str1 in
828
-
let headers1 = json1 |> Yojson.Basic.Util.member "headers" in
829
-
830
-
let session_header =
831
-
headers1
832
-
|> Yojson.Basic.Util.member "x-session"
833
-
|> Yojson.Basic.Util.to_string_option
834
-
|> Option.value ~default:""
835
-
in
836
-
837
-
Alcotest.(check string) "Session header persisted" "session-123" session_header;
838
-
839
-
let req = Requests.remove_default_header req "X-Session" in
840
-
841
-
let response2 = Requests.get req (base_url ^ "/echo") in
842
-
let body_str2 = Requests.Response.body response2 |> Eio.Flow.read_all in
843
-
let json2 = Yojson.Basic.from_string body_str2 in
844
-
let headers2 = json2 |> Yojson.Basic.Util.member "headers" in
845
-
846
-
let session_header2 =
847
-
headers2
848
-
|> Yojson.Basic.Util.member "x-session"
849
-
|> Yojson.Basic.Util.to_string_option
850
-
in
851
-
852
-
Alcotest.(check (option string)) "Session header removed" None session_header2
853
-
854
-
let () =
855
-
Logs.set_reporter (Logs.format_reporter ());
856
-
Logs.set_level (Some Logs.Warning);
857
-
858
-
let open Alcotest in
859
-
run "Requests Tests" [
860
-
"HTTP Methods", [
861
-
test_case "GET request" `Quick test_get_request;
862
-
test_case "POST request" `Quick test_post_request;
863
-
test_case "PUT request" `Quick test_put_request;
864
-
test_case "DELETE request" `Quick test_delete_request;
865
-
test_case "PATCH request" `Quick test_patch_request;
866
-
test_case "HEAD request" `Quick test_head_request;
867
-
test_case "OPTIONS request" `Quick test_options_request;
868
-
];
869
-
"Request Features", [
870
-
test_case "Custom headers" `Quick test_custom_headers;
871
-
test_case "Query parameters" `Quick test_query_params;
872
-
test_case "JSON body" `Quick test_json_body;
873
-
test_case "Form data" `Quick test_form_data;
874
-
test_case "Multipart upload" `Quick test_multipart;
875
-
test_case "Default headers" `Quick test_default_headers;
876
-
];
877
-
"Response Handling", [
878
-
test_case "Status codes" `Quick test_status_codes;
879
-
test_case "Response headers" `Quick test_response_headers;
880
-
test_case "Large response" `Quick test_large_response;
881
-
];
882
-
"Redirects", [
883
-
test_case "Follow redirects" `Quick test_redirects;
884
-
test_case "No follow redirects" `Quick test_no_redirect;
885
-
];
886
-
"Authentication", [
887
-
test_case "Bearer auth" `Quick test_bearer_auth;
888
-
test_case "Basic auth" `Quick test_basic_auth;
889
-
];
890
-
"Session Features", [
891
-
test_case "Cookies" `Quick test_cookies;
892
-
test_case "Session persistence" `Quick test_session_persistence;
893
-
];
894
-
"Advanced", [
895
-
test_case "Timeout handling" `Quick test_timeout;
896
-
test_case "Concurrent requests" `Quick test_concurrent_requests;
897
-
test_case "One module" `Quick test_one_module;
898
-
];
899
-
]
+2
-1
stack/requests_json_api/dune-project
+2
-1
stack/requests_json_api/dune-project
+1
-1
stack/requests_json_api/lib/dune
+1
-1
stack/requests_json_api/lib/dune
+83
-15
stack/requests_json_api/lib/requests_json_api.ml
+83
-15
stack/requests_json_api/lib/requests_json_api.ml
···
27
27
28
28
(** {1 JSON Helpers} *)
29
29
30
-
let parse_json parser body_str =
31
-
Ezjsonm.from_string body_str |> parser
30
+
let parse_json decoder body_str =
31
+
match Jsont_bytesrw.decode_string' decoder body_str with
32
+
| Ok v -> v
33
+
| Error e -> failwith (Fmt.str "JSON parse error: %s" (Jsont.Error.to_string e))
32
34
33
-
let parse_json_result parser body_str =
34
-
try Ok (parse_json parser body_str)
35
-
with exn -> Error (Printexc.to_string exn)
35
+
let parse_json_result decoder body_str =
36
+
match Jsont_bytesrw.decode_string' decoder body_str with
37
+
| Ok v -> Ok v
38
+
| Error e -> Error (Jsont.Error.to_string e)
36
39
37
-
let get_json_exn session url parser =
40
+
let get_json_exn session url decoder =
38
41
let response = Requests.get session url in
39
42
let status = Requests.Response.status_code response in
40
43
if status < 200 || status >= 300 then
41
44
failwith (Printf.sprintf "HTTP %d" status);
42
-
read_body response |> parse_json parser
45
+
read_body response |> parse_json decoder
43
46
44
-
let get_json session url parser =
47
+
let get_json session url decoder =
45
48
match get_result session url with
46
49
| Ok body ->
47
-
(match parse_json_result parser body with
50
+
(match parse_json_result decoder body with
48
51
| Ok result -> Ok result
49
52
| Error msg -> Error (`Json_error msg))
50
53
| Error (status, body) -> Error (`Http (status, body))
51
54
52
-
let post_json session url json_value =
53
-
let body_str = Ezjsonm.value_to_string json_value in
55
+
let post_json session url jsont_codec value =
56
+
let body_str = match Jsont_bytesrw.encode_string' jsont_codec value with
57
+
| Ok s -> s
58
+
| Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))
59
+
in
54
60
let body = Requests.Body.of_string Requests.Mime.json body_str in
55
61
Requests.post session url ~body
56
62
57
-
let post_json_exn session url json_value =
58
-
let response = post_json session url json_value in
63
+
let post_json_exn session url jsont_codec value =
64
+
let response = post_json session url jsont_codec value in
59
65
let status = Requests.Response.status_code response in
60
66
if status < 200 || status >= 300 then
61
67
failwith (Printf.sprintf "HTTP %d" status);
62
68
read_body response
63
69
64
-
let post_json_result session url json_value =
70
+
let post_json_result session url jsont_codec value =
65
71
try
66
-
let response = post_json session url json_value in
72
+
let response = post_json session url jsont_codec value in
67
73
check_2xx response
68
74
with exn ->
69
75
Error (0, Printexc.to_string exn)
76
+
77
+
let post_json_decode_exn session url ~req req_value ~resp =
78
+
let response = post_json session url req req_value in
79
+
let status = Requests.Response.status_code response in
80
+
if status < 200 || status >= 300 then
81
+
failwith (Printf.sprintf "HTTP %d" status);
82
+
read_body response |> parse_json resp
83
+
84
+
let post_json_decode session url ~req req_value ~resp =
85
+
try
86
+
let response = post_json session url req req_value in
87
+
match check_2xx response with
88
+
| Ok body ->
89
+
(match parse_json_result resp body with
90
+
| Ok result -> Ok result
91
+
| Error msg -> Error (`Json_error msg))
92
+
| Error (status, body) -> Error (`Http (status, body))
93
+
with exn ->
94
+
Error (`Http (0, Printexc.to_string exn))
95
+
96
+
let put_json_exn session url jsont_codec value =
97
+
let body_str = match Jsont_bytesrw.encode_string' jsont_codec value with
98
+
| Ok s -> s
99
+
| Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))
100
+
in
101
+
let body = Requests.Body.of_string Requests.Mime.json body_str in
102
+
let response = Requests.put session url ~body in
103
+
let status = Requests.Response.status_code response in
104
+
if status < 200 || status >= 300 then
105
+
failwith (Printf.sprintf "HTTP %d" status);
106
+
read_body response
107
+
108
+
let put_json_decode_exn session url ~req req_value ~resp =
109
+
let body_str = match Jsont_bytesrw.encode_string' req req_value with
110
+
| Ok s -> s
111
+
| Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))
112
+
in
113
+
let body = Requests.Body.of_string Requests.Mime.json body_str in
114
+
let response = Requests.put session url ~body in
115
+
let status = Requests.Response.status_code response in
116
+
if status < 200 || status >= 300 then
117
+
failwith (Printf.sprintf "HTTP %d" status);
118
+
read_body response |> parse_json resp
119
+
120
+
let patch_json_exn session url jsont_codec value =
121
+
let body_str = match Jsont_bytesrw.encode_string' jsont_codec value with
122
+
| Ok s -> s
123
+
| Error e -> failwith (Fmt.str "JSON encoding error: %s" (Jsont.Error.to_string e))
124
+
in
125
+
let body = Requests.Body.of_string Requests.Mime.json body_str in
126
+
let response = Requests.patch session url ~body in
127
+
let status = Requests.Response.status_code response in
128
+
if status < 200 || status >= 300 then
129
+
failwith (Printf.sprintf "HTTP %d" status);
130
+
read_body response
131
+
132
+
let delete_json_exn session url =
133
+
let response = Requests.delete session url in
134
+
let status = Requests.Response.status_code response in
135
+
if status < 200 || status >= 300 then
136
+
failwith (Printf.sprintf "HTTP %d" status);
137
+
read_body response
70
138
71
139
(** {1 URL Helpers} *)
72
140
+50
-12
stack/requests_json_api/lib/requests_json_api.mli
+50
-12
stack/requests_json_api/lib/requests_json_api.mli
···
8
8
{[
9
9
open Requests_json_api
10
10
11
+
(* Define a Jsont codec for your type *)
12
+
type user = { id : int; name : string }
13
+
14
+
let user_jsont =
15
+
Jsont.Object.map (fun id name -> { id; name })
16
+
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun u -> u.id)
17
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun u -> u.name)
18
+
|> Jsont.Object.finish
19
+
20
+
let users_jsont = Jsont.list user_jsont
21
+
11
22
let fetch_users session =
12
-
get_json_exn session (base_url / "users") parse_users
23
+
get_json_exn session (base_url / "users") users_jsont
13
24
]}
14
25
*)
15
26
16
27
(** {1 JSON Request Helpers} *)
17
28
18
-
val get_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> (Ezjsonm.value -> 'a) -> 'a
19
-
(** [get_json_exn session url parser] makes a GET request, checks status is 2xx,
20
-
reads and parses JSON body, then applies the parser function.
29
+
val get_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t -> 'a
30
+
(** [get_json_exn session url decoder] makes a GET request, checks status is 2xx,
31
+
reads and parses JSON body using the provided Jsont decoder.
21
32
Raises [Failure] on any error (HTTP, network, or JSON parse). *)
22
33
23
-
val get_json : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> (Ezjsonm.value -> 'a) ->
34
+
val get_json : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t ->
24
35
('a, [> `Http of int * string | `Json_error of string]) result
25
36
(** Like [get_json_exn] but returns [Result] instead of raising exceptions.
26
37
Returns [Ok parsed_value] on success, or [Error] with details on failure. *)
27
38
28
-
val post_json : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> Ezjsonm.value -> Requests.Response.t
29
-
(** [post_json session url json_value] creates a JSON request body and POSTs it to the URL.
39
+
val post_json : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t -> 'a -> Requests.Response.t
40
+
(** [post_json session url codec value] encodes [value] using the Jsont codec and POSTs it to the URL.
30
41
Returns the raw response for custom handling. *)
31
42
32
-
val post_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> Ezjsonm.value -> string
43
+
val post_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t -> 'a -> string
33
44
(** Like [post_json] but checks status is 2xx and returns the response body as a string.
34
45
Raises [Failure] on non-2xx status. *)
35
46
36
-
val post_json_result : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> Ezjsonm.value ->
47
+
val post_json_result : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t -> 'a ->
37
48
(string, int * string) result
38
49
(** Like [post_json_exn] but returns [Result] instead of raising.
39
50
[Ok body] on 2xx status, [Error (status, body)] otherwise. *)
40
51
52
+
val post_json_decode_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string ->
53
+
req:'a Jsont.t -> 'a -> resp:'b Jsont.t -> 'b
54
+
(** [post_json_decode_exn session url ~req req_value ~resp] encodes [req_value] using the [req] codec,
55
+
POSTs it to the URL, checks status is 2xx, and decodes the response using the [resp] codec.
56
+
Raises [Failure] on any error. *)
57
+
58
+
val post_json_decode : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string ->
59
+
req:'a Jsont.t -> 'a -> resp:'b Jsont.t ->
60
+
('b, [> `Http of int * string | `Json_error of string]) result
61
+
(** Like [post_json_decode_exn] but returns [Result] instead of raising. *)
62
+
63
+
val put_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t -> 'a -> string
64
+
(** [put_json_exn session url codec value] encodes [value] and PUTs it to the URL.
65
+
Returns response body. Raises [Failure] on non-2xx status. *)
66
+
67
+
val put_json_decode_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string ->
68
+
req:'a Jsont.t -> 'a -> resp:'b Jsont.t -> 'b
69
+
(** Like [post_json_decode_exn] but uses PUT method. *)
70
+
71
+
val patch_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> 'a Jsont.t -> 'a -> string
72
+
(** [patch_json_exn session url codec value] encodes [value] and PATCHes it to the URL.
73
+
Returns response body. Raises [Failure] on non-2xx status. *)
74
+
75
+
val delete_json_exn : (_ Eio.Time.clock, _ Eio.Net.t) Requests.t -> string -> string
76
+
(** [delete_json_exn session url] makes a DELETE request.
77
+
Returns response body. Raises [Failure] on non-2xx status. *)
78
+
41
79
(** {1 JSON Parsing Helpers} *)
42
80
43
-
val parse_json : (Ezjsonm.value -> 'a) -> string -> 'a
44
-
(** [parse_json parser body_str] parses a JSON string and applies the parser function.
81
+
val parse_json : 'a Jsont.t -> string -> 'a
82
+
(** [parse_json decoder body_str] parses a JSON string using the provided Jsont decoder.
45
83
Raises exception on parse error. *)
46
84
47
-
val parse_json_result : (Ezjsonm.value -> 'a) -> string -> ('a, string) result
85
+
val parse_json_result : 'a Jsont.t -> string -> ('a, string) result
48
86
(** Like [parse_json] but returns [Result] on parse error instead of raising. *)
49
87
50
88
(** {1 Low-Level Helpers} *)
+2
-1
stack/requests_json_api/requests_json_api.opam
+2
-1
stack/requests_json_api/requests_json_api.opam
+1
-1
stack/river/bin/dune
+1
-1
stack/river/bin/dune
+36
-38
stack/river/bin/river_cli.ml
+36
-38
stack/river/bin/river_cli.ml
···
38
38
with Eio.Io (Eio.Fs.E (Already_exists _), _) -> ()
39
39
) dirs
40
40
41
-
let user_of_json json =
42
-
let open Yojson.Safe.Util in
43
-
try
44
-
let feeds_json = json |> member "feeds" |> to_list in
45
-
let feeds = List.map (fun feed ->
46
-
{ River.name = feed |> member "name" |> to_string;
47
-
url = feed |> member "url" |> to_string }
48
-
) feeds_json in
49
-
Some {
50
-
username = json |> member "username" |> to_string;
51
-
fullname = json |> member "fullname" |> to_string;
52
-
email = json |> member "email" |> to_string_option;
53
-
feeds;
54
-
last_synced = json |> member "last_synced" |> to_string_option;
55
-
}
56
-
with _ -> None
41
+
(* JSON codecs for user data *)
42
+
43
+
(* Codec for River.source (feed) *)
44
+
let source_jsont =
45
+
let make name url = { River.name; url } in
46
+
Jsont.Object.map ~kind:"Source" make
47
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun s -> s.River.name)
48
+
|> Jsont.Object.mem "url" Jsont.string ~enc:(fun s -> s.River.url)
49
+
|> Jsont.Object.finish
50
+
51
+
(* Codec for user *)
52
+
let user_jsont =
53
+
let make username fullname email feeds last_synced =
54
+
{ username; fullname; email; feeds; last_synced }
55
+
in
56
+
Jsont.Object.map ~kind:"User" make
57
+
|> Jsont.Object.mem "username" Jsont.string ~enc:(fun u -> u.username)
58
+
|> Jsont.Object.mem "fullname" Jsont.string ~enc:(fun u -> u.fullname)
59
+
|> Jsont.Object.opt_mem "email" Jsont.string ~enc:(fun u -> u.email)
60
+
|> Jsont.Object.mem "feeds" (Jsont.list source_jsont) ~enc:(fun u -> u.feeds)
61
+
|> Jsont.Object.opt_mem "last_synced" Jsont.string ~enc:(fun u -> u.last_synced)
62
+
|> Jsont.Object.finish
63
+
64
+
let user_of_string s =
65
+
match Jsont_bytesrw.decode_string' user_jsont s with
66
+
| Ok user -> Some user
67
+
| Error err ->
68
+
Log.err (fun m -> m "Failed to parse user JSON: %s" (Jsont.Error.to_string err));
69
+
None
70
+
71
+
let user_to_string user =
72
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent user_jsont user with
73
+
| Ok s -> s
74
+
| Error err -> failwith ("Failed to encode user: " ^ Jsont.Error.to_string err)
57
75
58
76
let load_user state username =
59
77
let file = user_file state username in
60
78
try
61
79
let content = Eio.Path.load file in
62
-
let json = Yojson.Safe.from_string content in
63
-
user_of_json json
80
+
user_of_string content
64
81
with
65
82
| Eio.Io (Eio.Fs.E (Not_found _), _) -> None
66
83
| e ->
67
84
Log.err (fun m -> m "Error loading user %s: %s" username (Printexc.to_string e));
68
85
None
69
86
70
-
let user_to_json user =
71
-
let feeds_json = List.map (fun feed ->
72
-
`Assoc [
73
-
"name", `String feed.River.name;
74
-
"url", `String feed.River.url;
75
-
]
76
-
) user.feeds in
77
-
`Assoc [
78
-
"username", `String user.username;
79
-
"fullname", `String user.fullname;
80
-
"email", (match user.email with
81
-
| Some e -> `String e
82
-
| None -> `Null);
83
-
"feeds", `List feeds_json;
84
-
"last_synced", (match user.last_synced with
85
-
| Some s -> `String s
86
-
| None -> `Null);
87
-
]
88
-
89
87
let save_user state user =
90
88
let file = user_file state user.username in
91
-
let json = user_to_json user |> Yojson.Safe.to_string ~std:true in
89
+
let json = user_to_string user in
92
90
Eio.Path.save ~create:(`Or_truncate 0o644) file json
93
91
94
92
let list_users state =
+1
-2
stack/river/dune-project
+1
-2
stack/river/dune-project
+1
-1
stack/river/lib/dune
+1
-1
stack/river/lib/dune
···
2
2
(name river)
3
3
(public_name river)
4
4
(wrapped false)
5
-
(libraries eio eio_main requests requests_json_api logs str syndic lambdasoup uri ptime jsonfeed jsont bytesrw))
5
+
(libraries eio eio_main requests requests_json_api logs str syndic lambdasoup uri ptime jsonfeed jsont jsont.bytesrw cacheio xdge))
+264
-189
stack/river/lib/river_store.ml
+264
-189
stack/river/lib/river_store.ml
···
1
1
(*
2
-
* Persistent storage for Atom feed entries using Cacheio
2
+
* Persistent storage for Atom feed entries using Cacheio and Jsonfeed
3
3
*)
4
4
5
5
let src = Logs.Src.create "river.store" ~doc:"River persistent storage"
···
7
7
8
8
(* Types *)
9
9
10
-
type stored_entry = {
11
-
atom_id : string;
12
-
title : string;
13
-
link : Uri.t option;
14
-
published : Ptime.t option;
15
-
updated : Ptime.t;
16
-
author_name : string;
17
-
author_email : string option;
18
-
content : string;
10
+
(* Storage metadata that extends Jsonfeed.Item via unknown fields *)
11
+
type storage_meta = {
19
12
feed_url : string;
20
13
feed_name : string;
21
14
feed_title : string;
22
15
stored_at : Ptime.t;
23
-
tags : string list;
24
-
summary : string option;
16
+
}
17
+
18
+
(* A stored entry is a Jsonfeed.Item.t with storage metadata in unknown fields *)
19
+
type stored_entry = {
20
+
item : Jsonfeed.Item.t;
21
+
meta : storage_meta;
25
22
}
23
+
24
+
(* Stored entry accessors *)
25
+
let entry_item entry = entry.item
26
+
let entry_feed_url entry = entry.meta.feed_url
27
+
let entry_feed_name entry = entry.meta.feed_name
28
+
let entry_feed_title entry = entry.meta.feed_title
29
+
let entry_stored_at entry = entry.meta.stored_at
26
30
27
31
type feed_info = {
28
32
url : string;
···
54
58
let feed_key = make_feed_key feed_url in
55
59
feed_key ^ "/meta.json"
56
60
57
-
(* JSON serialization *)
61
+
(* JSON serialization using Jsonfeed and Jsont *)
58
62
59
-
let entry_to_json entry =
60
-
`Assoc [
61
-
"atom_id", `String entry.atom_id;
62
-
"title", `String entry.title;
63
-
"link", (match entry.link with
64
-
| Some u -> `String (Uri.to_string u)
65
-
| None -> `Null);
66
-
"published", (match entry.published with
67
-
| Some t -> `String (Ptime.to_rfc3339 t)
68
-
| None -> `Null);
69
-
"updated", `String (Ptime.to_rfc3339 entry.updated);
70
-
"author_name", `String entry.author_name;
71
-
"author_email", (match entry.author_email with Some e -> `String e | None -> `Null);
72
-
"content", `String entry.content;
73
-
"feed_url", `String entry.feed_url;
74
-
"feed_name", `String entry.feed_name;
75
-
"feed_title", `String entry.feed_title;
76
-
"stored_at", `String (Ptime.to_rfc3339 entry.stored_at);
77
-
"tags", `List (List.map (fun t -> `String t) entry.tags);
78
-
"summary", (match entry.summary with Some s -> `String s | None -> `Null);
79
-
]
63
+
(* Storage metadata codec - stores feed info and storage timestamp *)
64
+
let storage_meta_jsont : storage_meta Jsont.t =
65
+
Jsont.Object.(
66
+
map ~kind:"StorageMeta" (fun feed_url feed_name feed_title stored_at : storage_meta ->
67
+
{ feed_url; feed_name; feed_title; stored_at })
68
+
|> mem "x_river_feed_url" Jsont.string ~enc:(fun m -> m.feed_url)
69
+
|> mem "x_river_feed_name" Jsont.string ~enc:(fun m -> m.feed_name)
70
+
|> mem "x_river_feed_title" Jsont.string ~enc:(fun m -> m.feed_title)
71
+
|> mem "x_river_stored_at" Jsonfeed.Rfc3339.jsont ~enc:(fun m -> m.stored_at)
72
+
|> finish
73
+
)
80
74
81
-
let entry_of_json json =
82
-
let open Yojson.Safe.Util in
83
-
let parse_time s =
84
-
match Ptime.of_rfc3339 s with
85
-
| Ok (t, _, _) -> t
86
-
| Error _ -> failwith ("Invalid timestamp: " ^ s)
75
+
(* Codec for feed_info *)
76
+
let feed_meta_jsont : feed_info Jsont.t =
77
+
Jsont.Object.(
78
+
map ~kind:"FeedInfo" (fun url name title last_updated entry_count : feed_info ->
79
+
{ url; name; title; last_updated; entry_count })
80
+
|> mem "url" Jsont.string ~enc:(fun (m : feed_info) -> m.url)
81
+
|> mem "name" Jsont.string ~enc:(fun m -> m.name)
82
+
|> mem "title" Jsont.string ~enc:(fun m -> m.title)
83
+
|> mem "last_updated" Jsonfeed.Rfc3339.jsont ~enc:(fun m -> m.last_updated)
84
+
|> mem "entry_count" Jsont.int ~enc:(fun m -> m.entry_count)
85
+
|> finish
86
+
)
87
+
88
+
(* Helper to create item with storage metadata in unknown fields *)
89
+
let merge_storage_meta item meta =
90
+
let meta_json = Jsont_bytesrw.encode_string' storage_meta_jsont meta
91
+
|> Result.get_ok in
92
+
let meta_unknown = Jsont_bytesrw.decode_string' Jsont.json meta_json
93
+
|> Result.get_ok in
94
+
Jsonfeed.Item.create
95
+
~id:(Jsonfeed.Item.id item)
96
+
~content:(Jsonfeed.Item.content item)
97
+
?url:(Jsonfeed.Item.url item)
98
+
?external_url:(Jsonfeed.Item.external_url item)
99
+
?title:(Jsonfeed.Item.title item)
100
+
?summary:(Jsonfeed.Item.summary item)
101
+
?image:(Jsonfeed.Item.image item)
102
+
?banner_image:(Jsonfeed.Item.banner_image item)
103
+
?date_published:(Jsonfeed.Item.date_published item)
104
+
?date_modified:(Jsonfeed.Item.date_modified item)
105
+
?authors:(Jsonfeed.Item.authors item)
106
+
?tags:(Jsonfeed.Item.tags item)
107
+
?language:(Jsonfeed.Item.language item)
108
+
?attachments:(Jsonfeed.Item.attachments item)
109
+
?references:(Jsonfeed.Item.references item)
110
+
~unknown:meta_unknown
111
+
()
112
+
113
+
(* Helper to extract storage metadata from item's unknown fields *)
114
+
let extract_storage_meta item =
115
+
let unknown = Jsonfeed.Item.unknown item in
116
+
let meta_str = Jsont_bytesrw.encode_string' Jsont.json unknown |> Result.get_ok in
117
+
match Jsont_bytesrw.decode_string' storage_meta_jsont meta_str with
118
+
| Ok meta -> meta
119
+
| Error e -> failwith ("Missing storage metadata: " ^ Jsont.Error.to_string e)
120
+
121
+
(* Stored entry codec - just wraps Jsonfeed.Item.jsont *)
122
+
let stored_entry_jsont : stored_entry Jsont.t =
123
+
let kind = "StoredEntry" in
124
+
let of_string s =
125
+
match Jsont_bytesrw.decode_string' Jsonfeed.Item.jsont s with
126
+
| Ok item -> Ok { item; meta = extract_storage_meta item }
127
+
| Error e -> Error (Jsont.Error.to_string e)
128
+
in
129
+
let enc entry =
130
+
let item_with_meta = merge_storage_meta entry.item entry.meta in
131
+
match Jsont_bytesrw.encode_string' Jsonfeed.Item.jsont item_with_meta with
132
+
| Ok s -> s
133
+
| Error e -> failwith ("Failed to encode: " ^ Jsont.Error.to_string e)
87
134
in
88
-
{
89
-
atom_id = json |> member "atom_id" |> to_string;
90
-
title = json |> member "title" |> to_string;
91
-
link = json |> member "link" |> to_string_option |> Option.map Uri.of_string;
92
-
published = json |> member "published" |> to_string_option |> Option.map parse_time;
93
-
updated = json |> member "updated" |> to_string |> parse_time;
94
-
author_name = json |> member "author_name" |> to_string;
95
-
author_email = json |> member "author_email" |> to_string_option;
96
-
content = json |> member "content" |> to_string;
97
-
feed_url = json |> member "feed_url" |> to_string;
98
-
feed_name = json |> member "feed_name" |> to_string;
99
-
feed_title = json |> member "feed_title" |> to_string;
100
-
stored_at = json |> member "stored_at" |> to_string |> parse_time;
101
-
tags = (try json |> member "tags" |> to_list |> List.map to_string with _ -> []);
102
-
summary = (try json |> member "summary" |> to_string_option with _ -> None);
103
-
}
135
+
Jsont.of_of_string ~kind of_string ~enc
136
+
137
+
(* Encode/decode functions *)
138
+
let entry_to_string entry =
139
+
match Jsont_bytesrw.encode_string' stored_entry_jsont entry with
140
+
| Ok s -> s
141
+
| Error err -> failwith ("Failed to encode entry: " ^ Jsont.Error.to_string err)
142
+
143
+
let entry_of_string s =
144
+
match Jsont_bytesrw.decode_string' stored_entry_jsont s with
145
+
| Ok entry -> entry
146
+
| Error err -> failwith ("Failed to parse entry: " ^ Jsont.Error.to_string err)
104
147
105
-
let feed_meta_to_json meta =
106
-
`Assoc [
107
-
"url", `String meta.url;
108
-
"name", `String meta.name;
109
-
"title", `String meta.title;
110
-
"last_updated", `String (Ptime.to_rfc3339 meta.last_updated);
111
-
]
148
+
let feed_meta_to_string meta =
149
+
match Jsont_bytesrw.encode_string' feed_meta_jsont meta with
150
+
| Ok s -> s
151
+
| Error err -> failwith ("Failed to encode feed metadata: " ^ Jsont.Error.to_string err)
112
152
113
-
let feed_meta_of_json json =
114
-
let open Yojson.Safe.Util in
115
-
let parse_time s =
116
-
match Ptime.of_rfc3339 s with
117
-
| Ok (t, _, _) -> t
118
-
| Error _ -> failwith ("Invalid timestamp: " ^ s)
119
-
in
120
-
{
121
-
url = json |> member "url" |> to_string;
122
-
name = json |> member "name" |> to_string;
123
-
title = json |> member "title" |> to_string;
124
-
last_updated = json |> member "last_updated" |> to_string |> parse_time;
125
-
entry_count = 0; (* Will be counted separately *)
126
-
}
153
+
let feed_meta_of_string s =
154
+
match Jsont_bytesrw.decode_string' feed_meta_jsont s with
155
+
| Ok meta -> meta
156
+
| Error err -> failwith ("Failed to parse feed metadata: " ^ Jsont.Error.to_string err)
127
157
128
158
(* Store creation *)
129
159
···
142
172
Log.info (fun m -> m "Created River store with XDG at %a" Eio.Path.pp base_dir);
143
173
{ cache; base_dir }
144
174
145
-
(* Convert Post.t to stored_entry *)
146
-
let entry_of_post ~feed_url ~feed_name ~feed_title (post : Post.t) =
147
-
let atom_id = post.id in (* Use the post's unique ID *)
148
-
let updated = match post.date with
149
-
| Some d -> d
150
-
| None -> Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get
175
+
(* Convert Post.t to Jsonfeed.Item.t *)
176
+
let item_of_post ~feed_url ~feed_name ~feed_title (post : Post.t) =
177
+
let content =
178
+
let html = Soup.to_string post.content in
179
+
`Html html
151
180
in
152
-
let published = post.date in
153
-
{
154
-
atom_id;
155
-
title = post.title;
156
-
link = post.link;
157
-
published;
158
-
updated;
159
-
author_name = post.author;
160
-
author_email = if post.email = "" then None else Some post.email;
161
-
content = Soup.to_string post.content;
181
+
let url = Option.map Uri.to_string post.link in
182
+
let authors =
183
+
if post.author = "" then None
184
+
else Some [Jsonfeed.Author.create ~name:post.author ()]
185
+
in
186
+
let tags = if post.tags = [] then None else Some post.tags in
187
+
let item = Jsonfeed.Item.create
188
+
~id:post.id
189
+
~content
190
+
?url
191
+
?title:(if post.title = "" then None else Some post.title)
192
+
?summary:post.summary
193
+
?date_published:post.date
194
+
?date_modified:post.date
195
+
?authors
196
+
?tags
197
+
()
198
+
in
199
+
let meta = {
162
200
feed_url;
163
201
feed_name;
164
202
feed_title;
165
203
stored_at = Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get;
166
-
tags = post.tags;
167
-
summary = post.summary;
168
-
}
204
+
} in
205
+
{ item; meta }
169
206
170
-
(* Convert Syndic.Atom.entry to stored_entry *)
171
-
let entry_of_atom ~feed_url ~feed_name ~feed_title (atom_entry : Syndic.Atom.entry) =
207
+
(* Convert Syndic.Atom.entry to Jsonfeed.Item.t *)
208
+
let item_of_atom ~feed_url ~feed_name ~feed_title (atom_entry : Syndic.Atom.entry) =
172
209
let atom_id = Uri.to_string atom_entry.id in
173
-
let updated = atom_entry.updated in
174
-
let published = match atom_entry.published with
210
+
let date_modified = atom_entry.updated in
211
+
let date_published = match atom_entry.published with
175
212
| Some p -> Some p
176
213
| None -> Some atom_entry.updated
177
214
in
178
-
(* Extract author info - Syndic doesn't expose person record fields,
179
-
so we'll use placeholders and reconstruct via Atom.author later *)
180
-
let content = match atom_entry.content with
181
-
| Some (Syndic.Atom.Text s) -> s
182
-
| Some (Syndic.Atom.Html (_, s)) -> s
215
+
(* Extract content *)
216
+
let content_html = match atom_entry.content with
217
+
| Some (Syndic.Atom.Text s) -> Some s
218
+
| Some (Syndic.Atom.Html (_, s)) -> Some s
183
219
| Some (Syndic.Atom.Xhtml (_, nodes)) ->
184
220
let ns_prefix _ = Some "" in
185
-
String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) nodes)
186
-
| Some (Syndic.Atom.Mime _) | Some (Syndic.Atom.Src _) | None ->
187
-
(match atom_entry.summary with
188
-
| Some (Syndic.Atom.Text s) -> s
189
-
| Some (Syndic.Atom.Html (_, s)) -> s
190
-
| Some (Syndic.Atom.Xhtml (_, nodes)) ->
191
-
let ns_prefix _ = Some "" in
192
-
String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) nodes)
193
-
| None -> "")
221
+
Some (String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) nodes))
222
+
| Some (Syndic.Atom.Mime _) | Some (Syndic.Atom.Src _) | None -> None
223
+
in
224
+
let content_text = match atom_entry.summary with
225
+
| Some s -> Some (Util.string_of_text_construct s)
226
+
| None -> None
227
+
in
228
+
let content = match content_html, content_text with
229
+
| Some h, Some t -> `Both (h, t)
230
+
| Some h, None -> `Html h
231
+
| None, Some t -> `Text t
232
+
| None, None -> `Text "" (* Fallback *)
194
233
in
195
-
let link = try
196
-
Some (List.find (fun l -> l.Syndic.Atom.rel = Syndic.Atom.Alternate) atom_entry.links).href
234
+
let url = try
235
+
Some (Uri.to_string (List.find (fun l -> l.Syndic.Atom.rel = Syndic.Atom.Alternate) atom_entry.links).href)
197
236
with Not_found ->
198
237
match atom_entry.links with
199
-
| l :: _ -> Some l.href
238
+
| l :: _ -> Some (Uri.to_string l.href)
200
239
| [] -> None
201
240
in
202
-
(* Extract tags from categories *)
203
-
let tags = List.map (fun cat -> cat.Syndic.Atom.term) atom_entry.categories in
204
-
(* Extract summary *)
241
+
let tags =
242
+
let cat_tags = List.map (fun cat -> cat.Syndic.Atom.term) atom_entry.categories in
243
+
if cat_tags = [] then None else Some cat_tags
244
+
in
205
245
let summary = match atom_entry.summary with
206
246
| Some s -> Some (Util.string_of_text_construct s)
207
247
| None -> None
208
248
in
209
-
{
210
-
atom_id;
211
-
title = Util.string_of_text_construct atom_entry.title;
212
-
link;
213
-
published;
214
-
updated;
215
-
author_name = feed_name; (* Use feed name as fallback *)
216
-
author_email = None;
217
-
content;
249
+
let item = Jsonfeed.Item.create
250
+
~id:atom_id
251
+
~content
252
+
?url
253
+
~title:(Util.string_of_text_construct atom_entry.title)
254
+
?summary
255
+
?date_published
256
+
~date_modified
257
+
?tags
258
+
()
259
+
in
260
+
let meta = {
218
261
feed_url;
219
262
feed_name;
220
263
feed_title;
221
264
stored_at = Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get;
222
-
tags;
223
-
summary;
224
-
}
265
+
} in
266
+
{ item; meta }
225
267
226
268
(* Feed metadata management *)
227
269
let update_feed_meta store ~feed_url ~feed_name ~feed_title ~sw:_ =
···
233
275
last_updated = Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get;
234
276
entry_count = 0;
235
277
} in
236
-
let json = feed_meta_to_json meta |> Yojson.Safe.to_string in
237
-
let source = Eio.Flow.string_source json in
278
+
let json_str = feed_meta_to_string meta in
279
+
let source = Eio.Flow.string_source json_str in
238
280
Cacheio.put store.cache ~key ~source ~ttl:None ();
239
281
Log.debug (fun m -> m "Updated feed metadata for %s" feed_url)
240
282
···
245
287
| Some source ->
246
288
try
247
289
let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in
248
-
let json = Yojson.Safe.from_string json_str in
249
-
Some (feed_meta_of_json json)
290
+
Some (feed_meta_of_string json_str)
250
291
with e ->
251
292
Log.err (fun m -> m "Failed to parse feed metadata: %s" (Printexc.to_string e));
252
293
None
···
254
295
(* Entry storage *)
255
296
256
297
let store_entry store ~feed_url ~feed_name ~feed_title ~post ~sw =
257
-
let entry = entry_of_post ~feed_url ~feed_name ~feed_title post in
258
-
let key = make_entry_key feed_url entry.atom_id in
259
-
let json = entry_to_json entry |> Yojson.Safe.to_string in
260
-
let source = Eio.Flow.string_source json in
298
+
let entry = item_of_post ~feed_url ~feed_name ~feed_title post in
299
+
let key = make_entry_key feed_url (Jsonfeed.Item.id entry.item) in
300
+
let json_str = entry_to_string entry in
301
+
let source = Eio.Flow.string_source json_str in
261
302
Cacheio.put store.cache ~key ~source ~ttl:None ();
262
-
Log.debug (fun m -> m "Stored entry %s for feed %s" entry.atom_id feed_url);
303
+
Log.debug (fun m -> m "Stored entry %s for feed %s" (Jsonfeed.Item.id entry.item) feed_url);
263
304
(* Update feed metadata *)
264
305
update_feed_meta store ~feed_url ~feed_name ~feed_title ~sw
265
306
···
273
314
let store_atom_entries store ~feed_url ~feed_name ~feed_title ~entries ~sw =
274
315
Log.info (fun m -> m "Storing %d Atom entries for feed %s" (List.length entries) feed_url);
275
316
List.iter (fun atom_entry ->
276
-
let entry = entry_of_atom ~feed_url ~feed_name ~feed_title atom_entry in
277
-
let key = make_entry_key feed_url entry.atom_id in
278
-
let json = entry_to_json entry |> Yojson.Safe.to_string in
279
-
let source = Eio.Flow.string_source json in
317
+
let entry = item_of_atom ~feed_url ~feed_name ~feed_title atom_entry in
318
+
let key = make_entry_key feed_url (Jsonfeed.Item.id entry.item) in
319
+
let json_str = entry_to_string entry in
320
+
let source = Eio.Flow.string_source json_str in
280
321
Cacheio.put store.cache ~key ~source ~ttl:None ();
281
-
Log.debug (fun m -> m "Stored Atom entry %s" entry.atom_id);
322
+
Log.debug (fun m -> m "Stored Atom entry %s" (Jsonfeed.Item.id entry.item));
282
323
) entries;
283
324
update_feed_meta store ~feed_url ~feed_name ~feed_title ~sw;
284
325
Log.info (fun m -> m "Stored %d Atom entries for feed %s" (List.length entries) feed_url)
···
292
333
| Some source ->
293
334
try
294
335
let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in
295
-
let json = Yojson.Safe.from_string json_str in
296
-
Some (entry_of_json json)
336
+
Some (entry_of_string json_str)
297
337
with e ->
298
338
Log.err (fun m -> m "Failed to parse entry: %s" (Printexc.to_string e));
299
339
None
···
311
351
| Some source ->
312
352
try
313
353
let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in
314
-
let json = Yojson.Safe.from_string json_str in
315
-
Some (entry_of_json json)
354
+
Some (entry_of_string json_str)
316
355
with e ->
317
356
Log.err (fun m -> m "Failed to parse entry from scan: %s" (Printexc.to_string e));
318
357
None
319
358
else None
320
359
) entries in
321
-
(* Sort by updated time, newest first *)
322
-
List.sort (fun a b -> Ptime.compare b.updated a.updated) feed_entries
360
+
(* Sort by date_modified, newest first *)
361
+
List.sort (fun a b ->
362
+
let time_a = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in
363
+
let time_b = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in
364
+
Ptime.compare time_b time_a
365
+
) feed_entries
323
366
324
367
let list_entries_filtered store ~feed_url ?since ?until ?limit ?(sort=`Updated) () =
325
368
let entries = list_entries store ~feed_url in
326
369
(* Filter by time *)
327
370
let entries = match since with
328
371
| None -> entries
329
-
| Some t -> List.filter (fun e -> Ptime.is_later e.updated ~than:t || Ptime.equal e.updated t) entries
372
+
| Some t -> List.filter (fun e ->
373
+
let time = Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at in
374
+
Ptime.is_later time ~than:t || Ptime.equal time t) entries
330
375
in
331
376
let entries = match until with
332
377
| None -> entries
333
-
| Some t -> List.filter (fun e -> Ptime.is_earlier e.updated ~than:t || Ptime.equal e.updated t) entries
378
+
| Some t -> List.filter (fun e ->
379
+
let time = Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at in
380
+
Ptime.is_earlier time ~than:t || Ptime.equal time t) entries
334
381
in
335
382
(* Sort *)
336
383
let entries = match sort with
337
384
| `Published -> List.sort (fun a b ->
338
-
match a.published, b.published with
339
-
| Some pa, Some pb -> Ptime.compare pb pa
385
+
let pa = Jsonfeed.Item.date_published a.item in
386
+
let pb = Jsonfeed.Item.date_published b.item in
387
+
match pa, pb with
388
+
| Some ta, Some tb -> Ptime.compare tb ta
340
389
| None, Some _ -> 1
341
390
| Some _, None -> -1
342
-
| None, None -> Ptime.compare b.updated a.updated
391
+
| None, None ->
392
+
let ta = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in
393
+
let tb = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in
394
+
Ptime.compare tb ta
395
+
) entries
396
+
| `Updated -> List.sort (fun a b ->
397
+
let ta = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in
398
+
let tb = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in
399
+
Ptime.compare tb ta
343
400
) entries
344
-
| `Updated -> List.sort (fun a b -> Ptime.compare b.updated a.updated) entries
345
-
| `Stored -> List.sort (fun a b -> Ptime.compare b.stored_at a.stored_at) entries
401
+
| `Stored -> List.sort (fun a b -> Ptime.compare b.meta.stored_at a.meta.stored_at) entries
346
402
in
347
403
(* Limit *)
348
404
match limit with
···
365
421
| Some source ->
366
422
try
367
423
let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in
368
-
let json = Yojson.Safe.from_string json_str in
369
-
Some (entry_of_json json)
424
+
Some (entry_of_string json_str)
370
425
with e ->
371
426
Log.err (fun m -> m "Failed to parse entry: %s" (Printexc.to_string e));
372
427
None
373
428
else None
374
429
) entries in
375
-
let sorted = List.sort (fun a b -> Ptime.compare b.updated a.updated) all_entries in
430
+
let sorted = List.sort (fun a b ->
431
+
let ta = Jsonfeed.Item.date_modified a.item |> Option.value ~default:a.meta.stored_at in
432
+
let tb = Jsonfeed.Item.date_modified b.item |> Option.value ~default:b.meta.stored_at in
433
+
Ptime.compare tb ta
434
+
) all_entries in
376
435
List.filteri (fun i _ -> i < limit) sorted
377
436
378
437
let find_entry_by_id store ~id =
···
388
447
| Some source ->
389
448
(try
390
449
let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in
391
-
let json = Yojson.Safe.from_string json_str in
392
-
let entry = entry_of_json json in
450
+
let entry = entry_of_string json_str in
393
451
(* Exact ID match only *)
394
-
if entry.atom_id = id then
452
+
if Jsonfeed.Item.id entry.item = id then
395
453
Some entry
396
454
else
397
455
None
···
401
459
else None
402
460
) entries in
403
461
(match matching_entry with
404
-
| Some e -> Log.debug (fun m -> m "Found entry: %s" e.title)
462
+
| Some e -> Log.debug (fun m -> m "Found entry: %s"
463
+
(Jsonfeed.Item.title e.item |> Option.value ~default:"(no title)"))
405
464
| None -> Log.debug (fun m -> m "No entry found with ID: %s" id));
406
465
matching_entry
407
466
···
430
489
let entries = list_entries store ~feed_url in
431
490
let to_delete = List.filteri (fun i _ -> i >= keep) entries in
432
491
List.iter (fun entry ->
433
-
delete_entry store ~feed_url ~atom_id:entry.atom_id
492
+
delete_entry store ~feed_url ~atom_id:(Jsonfeed.Item.id entry.item)
434
493
) to_delete;
435
494
let deleted = List.length to_delete in
436
495
Log.info (fun m -> m "Pruned %d entries from feed %s (kept %d)" deleted feed_url keep);
···
439
498
let prune_old_entries store ~feed_url ~older_than =
440
499
let entries = list_entries store ~feed_url in
441
500
let to_delete = List.filter (fun e ->
442
-
Ptime.is_earlier e.updated ~than:older_than
501
+
let time = Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at in
502
+
Ptime.is_earlier time ~than:older_than
443
503
) entries in
444
504
List.iter (fun entry ->
445
-
delete_entry store ~feed_url ~atom_id:entry.atom_id
505
+
delete_entry store ~feed_url ~atom_id:(Jsonfeed.Item.id entry.item)
446
506
) to_delete;
447
507
let deleted = List.length to_delete in
448
508
Log.info (fun m -> m "Pruned %d old entries from feed %s" deleted feed_url);
···
461
521
| Some source ->
462
522
try
463
523
let json_str = Eio.Buf_read.(parse_exn take_all) source ~max_size:Int.max_int in
464
-
let json = Yojson.Safe.from_string json_str in
465
-
Some (feed_meta_of_json json)
524
+
Some (feed_meta_of_string json_str)
466
525
with e ->
467
526
Log.err (fun m -> m "Failed to parse feed metadata: %s" (Printexc.to_string e));
468
527
None
···
502
561
| Some n -> list_entries_filtered store ~feed_url ~limit:n ()
503
562
in
504
563
let atom_entries = List.map (fun entry ->
505
-
let id = Uri.of_string entry.atom_id in
506
-
let entry_title : Syndic.Atom.text_construct = Syndic.Atom.Text entry.title in
507
-
let links = match entry.link with
508
-
| Some uri -> [Syndic.Atom.link ~rel:Syndic.Atom.Alternate uri]
564
+
let item = entry.item in
565
+
let id = Uri.of_string (Jsonfeed.Item.id item) in
566
+
let entry_title : Syndic.Atom.text_construct =
567
+
Syndic.Atom.Text (Jsonfeed.Item.title item |> Option.value ~default:"(no title)") in
568
+
let links = match Jsonfeed.Item.url item with
569
+
| Some url_str -> [Syndic.Atom.link ~rel:Syndic.Atom.Alternate (Uri.of_string url_str)]
509
570
| None -> []
510
571
in
511
-
let entry_content : Syndic.Atom.content = Syndic.Atom.Html (None, entry.content) in
512
-
let author = Syndic.Atom.author ?email:entry.author_email entry.author_name in
572
+
let content_str = match Jsonfeed.Item.content item with
573
+
| `Html h -> h
574
+
| `Text t -> t
575
+
| `Both (h, _) -> h
576
+
in
577
+
let entry_content : Syndic.Atom.content = Syndic.Atom.Html (None, content_str) in
578
+
let author_name = match Jsonfeed.Item.authors item with
579
+
| Some (a :: _) -> Jsonfeed.Author.name a |> Option.value ~default:entry.meta.feed_name
580
+
| _ -> entry.meta.feed_name
581
+
in
582
+
let author = Syndic.Atom.author author_name in
513
583
let authors = (author, []) in
514
-
Syndic.Atom.entry ~id ~title:entry_title ~updated:entry.updated ?published:entry.published
584
+
let updated = Jsonfeed.Item.date_modified item |> Option.value ~default:entry.meta.stored_at in
585
+
Syndic.Atom.entry ~id ~title:entry_title ~updated
586
+
?published:(Jsonfeed.Item.date_published item)
515
587
~links ~content:entry_content ~authors ()
516
588
) entries in
517
589
let feed_title : Syndic.Atom.text_construct = match title with
···
521
593
let feed_id = Uri.of_string ("urn:river:archive:" ^ (Digest.string feed_url |> Digest.to_hex)) in
522
594
let feed_updated = match entries with
523
595
| [] -> Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get
524
-
| e :: _ -> e.updated
596
+
| e :: _ -> Jsonfeed.Item.date_modified e.item |> Option.value ~default:e.meta.stored_at
525
597
in
526
598
{
527
599
Syndic.Atom.id = feed_id;
···
551
623
(* Pretty printing *)
552
624
553
625
let pp_entry fmt entry =
626
+
let item = entry.item in
554
627
Format.fprintf fmt "@[<v 2>Entry:@,";
555
-
Format.fprintf fmt "ID: %s@," entry.atom_id;
556
-
Format.fprintf fmt "Title: %s@," entry.title;
557
-
Format.fprintf fmt "Link: %s@," (match entry.link with Some u -> Uri.to_string u | None -> "none");
558
-
Format.fprintf fmt "Published: %s@," (match entry.published with
559
-
| Some t -> Ptime.to_rfc3339 t
560
-
| None -> "unknown");
561
-
Format.fprintf fmt "Updated: %s@," (Ptime.to_rfc3339 entry.updated);
562
-
Format.fprintf fmt "Feed: %s (%s)@," entry.feed_name entry.feed_url;
563
-
Format.fprintf fmt "Stored: %s@]" (Ptime.to_rfc3339 entry.stored_at)
628
+
Format.fprintf fmt "ID: %s@," (Jsonfeed.Item.id item);
629
+
Format.fprintf fmt "Title: %s@," (Jsonfeed.Item.title item |> Option.value ~default:"(no title)");
630
+
Format.fprintf fmt "URL: %s@," (Jsonfeed.Item.url item |> Option.value ~default:"(none)");
631
+
(match Jsonfeed.Item.date_published item with
632
+
| Some t -> Format.fprintf fmt "Published: %s@," (Ptime.to_rfc3339 t)
633
+
| None -> ());
634
+
(match Jsonfeed.Item.date_modified item with
635
+
| Some t -> Format.fprintf fmt "Modified: %s@," (Ptime.to_rfc3339 t)
636
+
| None -> ());
637
+
Format.fprintf fmt "Feed: %s (%s)@," entry.meta.feed_name entry.meta.feed_url;
638
+
Format.fprintf fmt "Stored: %s@]" (Ptime.to_rfc3339 entry.meta.stored_at)
564
639
565
640
let pp_feed_info fmt info =
566
641
Format.fprintf fmt "@[<v 2>Feed:@,";
···
578
653
List.iter (fun feed ->
579
654
Format.fprintf fmt " - %s: %d entries@," feed.name feed.entry_count
580
655
) feeds;
581
-
Format.fprintf fmt "@]"
656
+
Format.fprintf fmt "@]"
+13
-38
stack/river/lib/river_store.mli
+13
-38
stack/river/lib/river_store.mli
···
40
40
(** Abstract type representing the store *)
41
41
type t
42
42
43
-
(** Stored entry with resolved URLs and metadata *)
44
-
type stored_entry = {
45
-
atom_id : string;
46
-
(** Unique Atom entry ID (used as key) *)
43
+
(** Stored entry - combines Jsonfeed.Item with storage metadata *)
44
+
type stored_entry
47
45
48
-
title : string;
49
-
(** Entry title *)
46
+
(** {2 Stored Entry Accessors} *)
50
47
51
-
link : Uri.t option;
52
-
(** Primary link (resolved against feed base URI) *)
48
+
val entry_item : stored_entry -> Jsonfeed.Item.t
49
+
(** Get the underlying Jsonfeed Item *)
53
50
54
-
published : Ptime.t option;
55
-
(** Publication date *)
51
+
val entry_feed_url : stored_entry -> string
52
+
(** Get the source feed URL *)
56
53
57
-
updated : Ptime.t;
58
-
(** Last update time *)
54
+
val entry_feed_name : stored_entry -> string
55
+
(** Get the source feed name *)
59
56
60
-
author_name : string;
61
-
(** Entry author name *)
57
+
val entry_feed_title : stored_entry -> string
58
+
(** Get the source feed title *)
62
59
63
-
author_email : string option;
64
-
(** Entry author email *)
65
-
66
-
content : string;
67
-
(** HTML content with resolved URLs *)
68
-
69
-
feed_url : string;
70
-
(** URL of the source feed *)
71
-
72
-
feed_name : string;
73
-
(** Name of the source feed *)
74
-
75
-
feed_title : string;
76
-
(** Title of the source feed *)
77
-
78
-
stored_at : Ptime.t;
79
-
(** When this entry was stored *)
80
-
81
-
tags : string list;
82
-
(** Tags associated with the entry *)
83
-
84
-
summary : string option;
85
-
(** Summary/excerpt of the entry *)
86
-
}
60
+
val entry_stored_at : stored_entry -> Ptime.t
61
+
(** Get the storage timestamp *)
87
62
88
63
(** Feed metadata *)
89
64
type feed_info = {
+1
-2
stack/river/river.opam
+1
-2
stack/river/river.opam
+1
-1
stack/typesense-client/dune
+1
-1
stack/typesense-client/dune
+2
-1
stack/typesense-client/dune-project
+2
-1
stack/typesense-client/dune-project
+2
-1
stack/typesense-client/typesense-client.opam
+2
-1
stack/typesense-client/typesense-client.opam
+175
-94
stack/typesense-client/typesense_client.ml
+175
-94
stack/typesense-client/typesense_client.ml
···
53
53
Error (Connection_error (Printexc.to_string exn))
54
54
55
55
(** Search result types *)
56
+
type highlight = {
57
+
field: string;
58
+
snippets: string list;
59
+
}
60
+
56
61
type search_result = {
57
62
id: string;
58
63
title: string;
59
64
content: string;
60
65
score: float;
61
66
collection: string;
62
-
highlights: (string * string list) list;
63
-
document: Ezjsonm.value; (* Store raw document for flexible field access *)
67
+
highlights: highlight list;
68
+
document: Jsont.json; (* Store raw document for flexible field access *)
64
69
}
65
70
66
71
type search_response = {
···
69
74
query_time: float;
70
75
}
71
76
72
-
(** Parse search result from JSON *)
73
-
let parse_search_result collection json =
74
-
let open Ezjsonm in
75
-
let document = get_dict json |> List.assoc "document" in
76
-
let highlights = try get_dict json |> List.assoc "highlights" with _ -> `A [] in
77
-
let score = try get_dict json |> List.assoc "text_match" |> get_float with _ -> 0.0 in
77
+
(* Jsont codecs *)
78
78
79
-
let id = get_dict document |> List.assoc "id" |> get_string in
80
-
let title = try get_dict document |> List.assoc "title" |> get_string with _ -> "" in
81
-
let content = try
79
+
(** Helper to find a field by name in the fields list *)
80
+
let find_field field_name fields =
81
+
List.find_opt (fun ((name, _), _value) -> name = field_name) fields
82
+
83
+
module Highlight = struct
84
+
let make field snippets = { field; snippets }
85
+
let field h = h.field
86
+
let snippets h = h.snippets
87
+
88
+
let jsont =
89
+
Jsont.Object.map ~kind:"Highlight" make
90
+
|> Jsont.Object.mem "field" Jsont.string ~enc:field
91
+
|> Jsont.Object.mem "snippets" (Jsont.list Jsont.string) ~enc:snippets
92
+
|> Jsont.Object.finish
93
+
end
94
+
95
+
module Search_result = struct
96
+
(* Helper to extract content from document based on collection *)
97
+
let extract_content collection document =
98
+
let get_string_field field_name =
99
+
match document with
100
+
| Jsont.Object (fields, _) ->
101
+
(match find_field field_name fields with
102
+
| Some (_, Jsont.String (s, _)) -> s
103
+
| _ -> "")
104
+
| _ -> ""
105
+
in
82
106
match collection with
83
-
| "papers" -> get_dict document |> List.assoc "abstract" |> get_string
84
-
| "projects" -> get_dict document |> List.assoc "description" |> get_string
85
-
| "news" -> get_dict document |> List.assoc "content" |> get_string
86
-
| "videos" -> get_dict document |> List.assoc "description" |> get_string
87
-
| "notes" -> get_dict document |> List.assoc "content" |> get_string
88
-
| "ideas" -> get_dict document |> List.assoc "description" |> get_string
89
-
| "contacts" -> get_dict document |> List.assoc "name" |> get_string
107
+
| "papers" -> get_string_field "abstract"
108
+
| "projects" -> get_string_field "description"
109
+
| "news" -> get_string_field "content"
110
+
| "videos" -> get_string_field "description"
111
+
| "notes" -> get_string_field "content"
112
+
| "ideas" -> get_string_field "description"
113
+
| "contacts" -> get_string_field "name"
90
114
| _ -> ""
91
-
with _ -> "" in
115
+
116
+
let make collection document highlights text_match =
117
+
let get_string_field field_name =
118
+
match document with
119
+
| Jsont.Object (fields, _) ->
120
+
(match find_field field_name fields with
121
+
| Some (_, Jsont.String (s, _)) -> s
122
+
| _ -> "")
123
+
| _ -> ""
124
+
in
125
+
let id = get_string_field "id" in
126
+
let title = get_string_field "title" in
127
+
let content = extract_content collection document in
128
+
let score = Option.value text_match ~default:0.0 in
129
+
let highlights = Option.value highlights ~default:[] in
130
+
{ id; title; content; score; collection; highlights; document }
92
131
93
-
let parse_highlights highlights =
94
-
try
95
-
get_list (fun h ->
96
-
let field = get_dict h |> List.assoc "field" |> get_string in
97
-
let snippets = get_dict h |> List.assoc "snippets" |> get_list get_string in
98
-
(field, snippets)
99
-
) highlights
100
-
with _ -> []
101
-
in
132
+
let document r = r.document
133
+
let highlights r = if r.highlights = [] then None else Some r.highlights
134
+
let score r = if r.score = 0.0 then None else Some r.score
135
+
136
+
let jsont collection =
137
+
Jsont.Object.map ~kind:"SearchResult" (make collection)
138
+
|> Jsont.Object.mem "document" Jsont.json ~enc:document
139
+
|> Jsont.Object.opt_mem "highlights" (Jsont.list Highlight.jsont) ~enc:highlights
140
+
|> Jsont.Object.opt_mem "text_match" Jsont.number ~enc:score
141
+
|> Jsont.Object.finish
142
+
end
102
143
103
-
{ id; title; content; score; collection; highlights = parse_highlights highlights; document }
144
+
module Search_response = struct
145
+
let make hits found search_time_ms =
146
+
{ hits; total = found; query_time = search_time_ms }
147
+
148
+
let hits r = r.hits
149
+
let total r = r.total
150
+
let query_time r = r.query_time
104
151
105
-
(** Parse search response from JSON *)
106
-
let parse_search_response collection json =
107
-
let open Ezjsonm in
108
-
let hits = get_dict json |> List.assoc "hits" |> get_list (parse_search_result collection) in
109
-
let total = get_dict json |> List.assoc "found" |> get_int in
110
-
let query_time = get_dict json |> List.assoc "search_time_ms" |> get_float in
111
-
{ hits; total; query_time }
152
+
let jsont collection =
153
+
Jsont.Object.map ~kind:"SearchResponse" make
154
+
|> Jsont.Object.mem "hits" (Jsont.list (Search_result.jsont collection)) ~enc:hits
155
+
|> Jsont.Object.mem "found" Jsont.int ~enc:total
156
+
|> Jsont.Object.mem "search_time_ms" Jsont.number ~enc:query_time
157
+
|> Jsont.Object.finish
158
+
end
112
159
113
160
(** Search a single collection *)
114
161
let search_collection client collection_name query ?(limit=10) ?(offset=0) () =
···
128
175
129
176
match make_request client path with
130
177
| Ok response_str ->
131
-
(match Requests_json_api.parse_json_result (parse_search_response collection_name) response_str with
178
+
(match Jsont_bytesrw.decode_string' (Search_response.jsont collection_name) response_str with
132
179
| Ok search_response -> Ok search_response
133
-
| Error msg -> Error (Json_error msg))
180
+
| Error error -> Error (Json_error (Jsont.Error.to_string error)))
134
181
| Error err -> Error err
135
182
136
183
(** Helper function to drop n elements from list *)
···
152
199
results: search_response list;
153
200
}
154
201
155
-
(** Parse multisearch response from JSON *)
156
-
let parse_multisearch_response json =
157
-
let open Ezjsonm in
158
-
let results_json = get_dict json |> List.assoc "results" |> get_list (fun r -> r) in
159
-
let results = List.mapi (fun i result_json ->
160
-
let collection_name = match i with
161
-
| 0 -> "contacts"
162
-
| 1 -> "news"
163
-
| 2 -> "notes"
164
-
| 3 -> "papers"
165
-
| 4 -> "projects"
166
-
| 5 -> "ideas"
167
-
| 6 -> "videos"
168
-
| _ -> "unknown"
169
-
in
170
-
parse_search_response collection_name result_json
171
-
) results_json in
172
-
{ results }
202
+
(* Multisearch response decoder - needs special handling for collection names *)
203
+
let decode_multisearch_response collections json_str =
204
+
(* First decode as generic JSON *)
205
+
match Jsont_bytesrw.decode_string' Jsont.json json_str with
206
+
| Error e -> Error e
207
+
| Ok json ->
208
+
(* Extract the results array *)
209
+
match json with
210
+
| Jsont.Object (fields, _) ->
211
+
(match find_field "results" fields with
212
+
| Some (_, Jsont.Array (results_array, _)) ->
213
+
(* Decode each result with its corresponding collection name *)
214
+
let decode_result idx result_json =
215
+
let collection = List.nth collections idx in
216
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json result_json with
217
+
| Error e -> Error e
218
+
| Ok result_str ->
219
+
Jsont_bytesrw.decode_string' (Search_response.jsont collection) result_str
220
+
in
221
+
let rec decode_all idx acc = function
222
+
| [] -> Ok (List.rev acc)
223
+
| hd :: tl ->
224
+
match decode_result idx hd with
225
+
| Error e -> Error e
226
+
| Ok result -> decode_all (idx + 1) (result :: acc) tl
227
+
in
228
+
(match decode_all 0 [] results_array with
229
+
| Ok results -> Ok { results }
230
+
| Error e -> Error e)
231
+
| _ -> Error (Jsont.Error.msg Jsont.Meta.none "Missing or invalid results field"))
232
+
| _ -> Error (Jsont.Error.msg Jsont.Meta.none "Expected JSON object")
173
233
174
234
(** Perform multisearch across all collections *)
175
235
let multisearch client query ?(limit=10) () =
···
184
244
("videos", "title,description,channel,platform,tags");
185
245
] in
186
246
247
+
(* Build search request objects *)
187
248
let searches = List.map (fun collection ->
188
249
let query_by = List.assoc collection query_by_collection in
189
-
Ezjsonm.dict [
190
-
("collection", Ezjsonm.string collection);
191
-
("q", Ezjsonm.string query);
192
-
("query_by", Ezjsonm.string query_by);
193
-
("exclude_fields", Ezjsonm.string "embedding");
194
-
("per_page", Ezjsonm.int limit);
195
-
]
250
+
Jsont.Object ([
251
+
(("collection", Jsont.Meta.none), Jsont.String (collection, Jsont.Meta.none));
252
+
(("q", Jsont.Meta.none), Jsont.String (query, Jsont.Meta.none));
253
+
(("query_by", Jsont.Meta.none), Jsont.String (query_by, Jsont.Meta.none));
254
+
(("exclude_fields", Jsont.Meta.none), Jsont.String ("embedding", Jsont.Meta.none));
255
+
(("per_page", Jsont.Meta.none), Jsont.Number (float_of_int limit, Jsont.Meta.none));
256
+
], Jsont.Meta.none)
196
257
) collections in
197
258
198
-
let body = Ezjsonm.dict [("searches", Ezjsonm.list (fun x -> x) searches)] |> Ezjsonm.value_to_string in
259
+
let request_obj = Jsont.Object ([
260
+
(("searches", Jsont.Meta.none), Jsont.Array (searches, Jsont.Meta.none));
261
+
], Jsont.Meta.none) in
199
262
200
-
match make_request client ~meth:`POST ~body "/multi_search" with
201
-
| Ok response_str ->
202
-
(match Requests_json_api.parse_json_result parse_multisearch_response response_str with
203
-
| Ok multisearch_resp -> Ok multisearch_resp
204
-
| Error msg -> Error (Json_error msg))
205
-
| Error err -> Error err
263
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json request_obj with
264
+
| Error encode_error -> Error (Json_error (Jsont.Error.to_string encode_error))
265
+
| Ok body ->
266
+
match make_request client ~meth:`POST ~body "/multi_search" with
267
+
| Ok response_str ->
268
+
(match decode_multisearch_response collections response_str with
269
+
| Ok multisearch_resp -> Ok multisearch_resp
270
+
| Error error -> Error (Json_error (Jsont.Error.to_string error)))
271
+
| Error err -> Error err
206
272
207
273
(** Combine multisearch results into single result set *)
208
274
let combine_multisearch_results (multisearch_resp : multisearch_response) ?(limit=10) ?(offset=0) () =
···
226
292
227
293
(** List all collections *)
228
294
let list_collections client =
229
-
let parse_collections json =
230
-
Ezjsonm.get_list (fun c ->
231
-
let name = Ezjsonm.get_dict c |> List.assoc "name" |> Ezjsonm.get_string in
232
-
let num_docs = Ezjsonm.get_dict c |> List.assoc "num_documents" |> Ezjsonm.get_int in
233
-
(name, num_docs)
234
-
) json
235
-
in
295
+
let module Collection_info = struct
296
+
let make name num_documents = (name, num_documents)
297
+
let name ci = fst ci
298
+
let num_documents ci = snd ci
299
+
300
+
let jsont =
301
+
Jsont.Object.map ~kind:"CollectionInfo" make
302
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
303
+
|> Jsont.Object.mem "num_documents" Jsont.int ~enc:num_documents
304
+
|> Jsont.Object.finish
305
+
end in
306
+
236
307
match make_request client "/collections" with
237
308
| Ok response_str ->
238
-
(match Requests_json_api.parse_json_result parse_collections response_str with
309
+
(match Jsont_bytesrw.decode_string' (Jsont.list Collection_info.jsont) response_str with
239
310
| Ok collections -> Ok collections
240
-
| Error msg -> Error (Json_error msg))
311
+
| Error error -> Error (Json_error (Jsont.Error.to_string error)))
241
312
| Error err -> Error err
242
313
243
314
(** Pretty printer utilities *)
244
315
245
316
(** Extract field value from JSON document or return empty string if not found *)
246
-
let extract_field_string document field =
247
-
try
248
-
let open Ezjsonm in
249
-
get_dict document |> List.assoc field |> get_string
250
-
with _ -> ""
317
+
let extract_field_string document field_name =
318
+
match document with
319
+
| Jsont.Object (fields, _) ->
320
+
(match find_field field_name fields with
321
+
| Some (_, Jsont.String (s, _)) -> s
322
+
| _ -> "")
323
+
| _ -> ""
251
324
252
325
(** Extract field value from JSON document as string list or return empty list if not found *)
253
-
let extract_field_string_list document field =
254
-
try
255
-
let open Ezjsonm in
256
-
get_dict document |> List.assoc field |> get_list get_string
257
-
with _ -> []
326
+
let extract_field_string_list document field_name =
327
+
match document with
328
+
| Jsont.Object (fields, _) ->
329
+
(match find_field field_name fields with
330
+
| Some (_, Jsont.Array (items, _)) ->
331
+
List.filter_map (function
332
+
| Jsont.String (s, _) -> Some s
333
+
| _ -> None
334
+
) items
335
+
| _ -> [])
336
+
| _ -> []
258
337
259
338
(** Extract field value from JSON document as boolean or return false if not found *)
260
-
let extract_field_bool document field =
261
-
try
262
-
let open Ezjsonm in
263
-
get_dict document |> List.assoc field |> get_bool
264
-
with _ -> false
339
+
let extract_field_bool document field_name =
340
+
match document with
341
+
| Jsont.Object (fields, _) ->
342
+
(match find_field field_name fields with
343
+
| Some (_, Jsont.Bool (b, _)) -> b
344
+
| _ -> false)
345
+
| _ -> false
265
346
266
347
(** Format authors list for display *)
267
348
let format_authors authors =
+12
-5
stack/typesense-client/typesense_client.mli
+12
-5
stack/typesense-client/typesense_client.mli
···
27
27
val pp_error : Format.formatter -> error -> unit
28
28
29
29
(** Search result types *)
30
+
31
+
(** A highlight snippet from a search result *)
32
+
type highlight = {
33
+
field: string;
34
+
snippets: string list;
35
+
}
36
+
30
37
type search_result = {
31
38
id: string;
32
39
title: string;
33
40
content: string;
34
41
score: float;
35
42
collection: string;
36
-
highlights: (string * string list) list;
37
-
document: Ezjsonm.value; (* Store raw document for flexible field access *)
43
+
highlights: highlight list;
44
+
document: Jsont.json; (* Store raw document for flexible field access *)
38
45
}
39
46
40
47
type search_response = {
···
80
87
((string * int) list, error) result
81
88
82
89
(** Pretty printer utilities *)
83
-
val extract_field_string : Ezjsonm.value -> string -> string
84
-
val extract_field_string_list : Ezjsonm.value -> string -> string list
85
-
val extract_field_bool : Ezjsonm.value -> string -> bool
90
+
val extract_field_string : Jsont.json -> string -> string
91
+
val extract_field_string_list : Jsont.json -> string -> string list
92
+
val extract_field_bool : Jsont.json -> string -> bool
86
93
val format_authors : string list -> string
87
94
val format_date : string -> string
88
95
val format_tags : string list -> string
+1
-1
stack/zotero-translation/dune
+1
-1
stack/zotero-translation/dune
+2
-1
stack/zotero-translation/dune-project
+2
-1
stack/zotero-translation/dune-project
+2
-1
stack/zotero-translation/zotero-translation.opam
+2
-1
stack/zotero-translation/zotero-translation.opam
+105
-58
stack/zotero-translation/zotero_translation.ml
+105
-58
stack/zotero-translation/zotero_translation.ml
···
1
1
(** Resolve a DOI from a Zotero translation server *)
2
2
3
-
module J = Ezjsonm
4
-
5
3
(* From the ZTS source code: https://github.com/zotero/translation-server/blob/master/src/formats.js
6
4
bibtex: "9cb70025-a888-4a29-a210-93ec52da40d4",
7
5
biblatex: "b6e39b57-8942-4d11-8259-342c46ce395f",
···
104
102
requests_session: ('clock, 'net) Requests.t;
105
103
}
106
104
107
-
let create ~sw ~env ?requests_session base_uri =
108
-
let requests_session = match requests_session with
109
-
| Some session -> session
110
-
| None -> Requests.create ~sw env
111
-
in
105
+
let create ~requests_session base_uri =
112
106
{ base_uri; requests_session }
113
-
114
-
let v _base_uri =
115
-
failwith "Zotero_translation.v is deprecated. Use Zotero_translation.create ~sw ~env base_uri instead"
116
107
117
108
let resolve_doi { base_uri; requests_session } doi =
118
109
let body_str = "https://doi.org/" ^ doi in
···
123
114
let body = Requests.Response.body response |> Eio.Flow.read_all in
124
115
if status = 200 then begin
125
116
try
126
-
let doi_json = J.from_string body in
127
-
Ok doi_json
117
+
match Jsont_bytesrw.decode_string' Jsont.json body with
118
+
| Ok doi_json -> Ok doi_json
119
+
| Error e -> Error (`Msg (Jsont.Error.to_string e))
128
120
with exn -> Error (`Msg (Printexc.to_string exn))
129
121
end else
130
122
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
···
138
130
let body = Requests.Response.body response |> Eio.Flow.read_all in
139
131
if status = 200 then begin
140
132
try
141
-
let url_json = J.from_string body in
142
-
Ok url_json
133
+
match Jsont_bytesrw.decode_string' Jsont.json body with
134
+
| Ok url_json -> Ok url_json
135
+
| Error e -> Error (`Msg (Jsont.Error.to_string e))
143
136
with exn -> Error (`Msg (Printexc.to_string exn))
144
137
end else
145
138
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
···
153
146
let body = Requests.Response.body response |> Eio.Flow.read_all in
154
147
if status = 200 then begin
155
148
try
156
-
let doi_json = J.from_string body in
157
-
Ok doi_json
149
+
match Jsont_bytesrw.decode_string' Jsont.json body with
150
+
| Ok doi_json -> Ok doi_json
151
+
| Error e -> Error (`Msg (Jsont.Error.to_string e))
158
152
with exn -> Error (`Msg (Printexc.to_string exn))
159
153
end else
160
154
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
161
155
162
156
let export { base_uri; requests_session } format api =
163
-
let body_str = J.to_string api in
164
-
let uri = Uri.with_query' (export_endp base_uri ) ["format", (format_to_string format)] in
165
-
let body = Requests.Body.of_string Requests.Mime.json body_str in
166
-
let response = Requests.post requests_session ~body (Uri.to_string uri) in
167
-
let status = Requests.Response.status_code response in
168
-
let body = Requests.Response.body response |> Eio.Flow.read_all in
169
-
if status = 200 then begin
170
-
try
171
-
match format with
172
-
| Bibtex -> Ok (Astring.String.trim body)
173
-
| _ -> Ok body
174
-
with exn -> Error (`Msg (Printexc.to_string exn))
175
-
end else
176
-
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
157
+
match Jsont_bytesrw.encode_string' Jsont.json api with
158
+
| Error e -> Error (`Msg (Jsont.Error.to_string e))
159
+
| Ok body_str ->
160
+
let uri = Uri.with_query' (export_endp base_uri ) ["format", (format_to_string format)] in
161
+
let body = Requests.Body.of_string Requests.Mime.json body_str in
162
+
let response = Requests.post requests_session ~body (Uri.to_string uri) in
163
+
let status = Requests.Response.status_code response in
164
+
let body = Requests.Response.body response |> Eio.Flow.read_all in
165
+
if status = 200 then begin
166
+
try
167
+
match format with
168
+
| Bibtex -> Ok (Astring.String.trim body)
169
+
| _ -> Ok body
170
+
with exn -> Error (`Msg (Printexc.to_string exn))
171
+
end else
172
+
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
177
173
178
174
let unescape_hex s =
179
175
let buf = Buffer.create (String.length s) in
···
206
202
| Ok [bib] ->
207
203
let f = Bibtex.fields bib |> Bibtex.SM.bindings |> List.map (fun (k,v) -> k, (unescape_bibtex v)) in
208
204
let ty = match Bibtex.type' bib with "inbook" -> "book" | x -> x in
209
-
let v = List.fold_left (fun acc (k,v) -> (k,(`String v))::acc) ["bibtype",`String ty] f in
205
+
let v = List.fold_left (fun acc (k,v) -> ((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))::acc)
206
+
[(("bibtype", Jsont.Meta.none), Jsont.String (ty, Jsont.Meta.none))] f in
210
207
v
211
208
| Ok _ -> failwith "one bib at a time plz"
212
209
213
210
let bib_of_doi zt doi =
214
211
prerr_endline ("Fetching " ^ doi);
215
-
let v = match resolve_doi zt doi with
216
-
| Ok r -> r
212
+
match resolve_doi zt doi with
217
213
| Error (`Msg _) ->
218
214
Printf.eprintf "%s failed on /web, trying to /search\n%!" doi;
219
-
match search_id zt doi with
215
+
begin match search_id zt doi with
220
216
| Error (`Msg e) -> failwith e
221
-
| Ok r -> r
222
-
in
223
-
match export zt Bibtex v with
224
-
| Error (`Msg e) -> failwith e
225
-
| Ok r ->
226
-
print_endline r;
227
-
r
217
+
| Ok v ->
218
+
match export zt Bibtex v with
219
+
| Error (`Msg e) -> failwith e
220
+
| Ok r ->
221
+
print_endline r;
222
+
r
223
+
end
224
+
| Ok v ->
225
+
match export zt Bibtex v with
226
+
| Error (`Msg e) -> failwith e
227
+
| Ok r ->
228
+
print_endline r;
229
+
r
230
+
231
+
(* Helper to get string from Jsont.json *)
232
+
let get_string = function
233
+
| Jsont.String (s, _) -> s
234
+
| _ -> failwith "Expected string in JSON"
235
+
236
+
(* Helper to get list from Jsont.json *)
237
+
let get_list f = function
238
+
| Jsont.Array (arr, _) -> List.map f arr
239
+
| _ -> failwith "Expected array in JSON"
240
+
241
+
(* Helper to find a field in Jsont.Object *)
242
+
let find_field name = function
243
+
| Jsont.Object (mems, _) ->
244
+
List.find_map (fun ((k, _), v) -> if k = name then Some v else None) mems
245
+
| _ -> None
246
+
247
+
(* Helper to get a required field as string *)
248
+
let get_field name json =
249
+
match find_field name json with
250
+
| Some v -> get_string v
251
+
| None -> failwith ("Missing field: " ^ name)
252
+
253
+
(* Helper to update a field in a Jsont.Object *)
254
+
let update_field name value json =
255
+
match json with
256
+
| Jsont.Object (mems, meta) ->
257
+
let mems' =
258
+
match value with
259
+
| None -> List.filter (fun ((k, _), _) -> k <> name) mems
260
+
| Some v ->
261
+
let without = List.filter (fun ((k, _), _) -> k <> name) mems in
262
+
((name, Jsont.Meta.none), v) :: without
263
+
in
264
+
Jsont.Object (mems', meta)
265
+
| _ -> json
228
266
229
267
let split_authors keys =
268
+
let json = Jsont.Object (keys, Jsont.Meta.none) in
269
+
let author_str = get_field "author" json in
230
270
let authors =
231
-
List.assoc "author" keys |> J.get_string |>
232
-
Astring.String.cuts ~empty:false ~sep:" and " |>
271
+
Astring.String.cuts ~empty:false ~sep:" and " author_str |>
233
272
List.map Bibtex.list_value |>
234
273
List.map (fun v -> List.rev v |> String.concat " ") |>
235
-
List.map (fun x -> `String x)
274
+
List.map (fun x -> Jsont.String (x, Jsont.Meta.none))
236
275
in
237
276
let keywords =
238
-
List.assoc_opt "keywords" keys |> function
277
+
match find_field "keywords" json with
239
278
| None -> []
240
279
| Some k ->
241
-
Astring.String.cuts ~empty:false ~sep:", " (J.get_string k) |>
242
-
List.map (fun x -> `String x)
280
+
Astring.String.cuts ~empty:false ~sep:", " (get_string k) |>
281
+
List.map (fun x -> Jsont.String (x, Jsont.Meta.none))
243
282
in
244
-
J.update (`O keys) ["author"] (Some (`A authors)) |> fun j ->
245
-
J.update j ["keywords"] (match keywords with [] -> None | _ -> Some (`A keywords))
283
+
let json' = update_field "author" (Some (Jsont.Array (authors, Jsont.Meta.none))) json in
284
+
let json'' = update_field "keywords"
285
+
(match keywords with [] -> None | _ -> Some (Jsont.Array (keywords, Jsont.Meta.none))) json' in
286
+
match json'' with
287
+
| Jsont.Object (mems, _) -> mems
288
+
| _ -> failwith "Expected object"
246
289
247
290
let add_bibtex ~slug y =
248
-
let (.%{}) = fun y k -> J.find y [k] in
291
+
let json = Jsont.Object (y, Jsont.Meta.none) in
292
+
let find_opt k = find_field k json in
249
293
let add_if_present k f m =
250
-
match J.find y [k] with
251
-
| v -> Bibtex.SM.add k (f v) m
252
-
| exception Not_found -> m in
253
-
let string k m = add_if_present k J.get_string m in
254
-
let authors m = add_if_present "author" (fun j -> J.get_list J.get_string j |> String.concat " and ") m in
294
+
match find_opt k with
295
+
| Some v -> Bibtex.SM.add k (f v) m
296
+
| None -> m
297
+
in
298
+
let string k m = add_if_present k get_string m in
299
+
let authors m = add_if_present "author" (fun j -> get_list get_string j |> String.concat " and ") m in
255
300
let cite_key = Astring.String.map (function '-' -> '_' |x -> x) slug in
256
301
let fields = Bibtex.SM.empty in
257
-
let type' = y.%{"bibtype"} |> J.get_string |> String.lowercase_ascii in
302
+
let type' = get_field "bibtype" json |> String.lowercase_ascii in
258
303
let fields = authors fields |> string "title" |> string "doi" |> string "month" |> string "year" |> string "url" in
259
304
let fields = match type' with
260
305
| "article" -> string "journal" fields |> string "volume" |> string "number" |> string "pages"
···
264
309
| "misc" -> string "howpublished" fields
265
310
| "techreport" -> string "institution" fields |> string "number" |> string "address"
266
311
| b -> prerr_endline ("unknown bibtype " ^ b); fields in
267
-
Bibtex.v ~type' ~cite_key ~fields () |> Fmt.str "%a" Bibtex.pp |>
268
-
fun bib -> J.update y ["bib"] (Some (`String bib))
312
+
let bib = Bibtex.v ~type' ~cite_key ~fields () |> Fmt.str "%a" Bibtex.pp in
313
+
match update_field "bib" (Some (Jsont.String (bib, Jsont.Meta.none))) json with
314
+
| Jsont.Object (mems, _) -> mems
315
+
| _ -> failwith "Expected object"
269
316
270
317
let json_of_doi zt ~slug doi =
271
318
let x = bib_of_doi zt doi in
+8
-16
stack/zotero-translation/zotero_translation.mli
+8
-16
stack/zotero-translation/zotero_translation.mli
···
25
25
val format_of_string: string -> format option
26
26
27
27
(** Create a Zotero Translation client.
28
-
@param requests_session Optional Requests session for connection pooling.
29
-
If not provided, a new session is created. *)
28
+
@param requests_session Shared Requests session for connection pooling.
29
+
@param base_uri Base URI of the Zotero translation server (e.g., "http://localhost:1969"). *)
30
30
val create :
31
-
sw:Eio.Switch.t ->
32
-
env:< clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t;
33
-
net: ([> [> `Generic ] Eio.Net.ty ] as 'net) Eio.Resource.t;
34
-
fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->
35
-
?requests_session:('clock Eio.Resource.t, 'net Eio.Resource.t) Requests.t ->
31
+
requests_session:('clock Eio.Resource.t, 'net Eio.Resource.t) Requests.t ->
36
32
string -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t
37
33
38
-
(** Deprecated: use [create] instead *)
39
-
val v : string -> (_, _) t
40
-
[@@deprecated "Use create ~sw ~env base_uri instead"]
41
-
42
34
val resolve_doi: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
43
-
string -> (Ezjsonm.t, [>`Msg of string]) result
35
+
string -> (Jsont.json, [>`Msg of string]) result
44
36
45
37
val resolve_url: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
46
-
string -> (Ezjsonm.t, [>`Msg of string]) result
38
+
string -> (Jsont.json, [>`Msg of string]) result
47
39
48
40
val search_id: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
49
-
string -> (Ezjsonm.t, [>`Msg of string]) result
41
+
string -> (Jsont.json, [>`Msg of string]) result
50
42
51
43
val export: ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
52
-
format -> Ezjsonm.t -> (string, [>`Msg of string]) result
44
+
format -> Jsont.json -> (string, [>`Msg of string]) result
53
45
54
46
val json_of_doi : ([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
55
-
slug:string -> string -> Ezjsonm.value
47
+
slug:string -> string -> Jsont.object'
+217
stack/zulip/ARCHITECTURE.md
+217
stack/zulip/ARCHITECTURE.md
···
1
+
# Zulip Library Architecture
2
+
3
+
## Overview
4
+
5
+
The Zulip OCaml library follows a clean, layered architecture that separates protocol types, encoding concerns, and HTTP communication.
6
+
7
+
## Architecture Layers
8
+
9
+
```
10
+
┌─────────────────────────────────────┐
11
+
│ API Modules (Messages, Channels) │ ← High-level operations
12
+
├─────────────────────────────────────┤
13
+
│ Protocol Types (Message, Channel) │ ← Business logic types with Jsont codecs
14
+
├─────────────────────────────────────┤
15
+
│ Encode Module │ ← JSON/Form encoding utilities
16
+
├─────────────────────────────────────┤
17
+
│ Client Module │ ← HTTP request/response handling
18
+
├─────────────────────────────────────┤
19
+
│ Requests Library (EIO-based) │ ← Low-level HTTP
20
+
└─────────────────────────────────────┘
21
+
```
22
+
23
+
## Key Design Principles
24
+
25
+
### 1. **Protocol Types with Jsont Codecs**
26
+
27
+
Each Zulip API type (Message, Channel, User, etc.) has:
28
+
- A clean OCaml record type
29
+
- A `jsont` codec that defines bidirectional JSON conversion
30
+
- Accessor functions
31
+
- Pretty printer
32
+
33
+
Example from `channel.ml`:
34
+
```ocaml
35
+
type t = {
36
+
name : string;
37
+
description : string;
38
+
invite_only : bool;
39
+
history_public_to_subscribers : bool;
40
+
}
41
+
42
+
let jsont =
43
+
Jsont.Object.map ~kind:"Channel" make
44
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
45
+
|> Jsont.Object.mem "description" Jsont.string ~enc:description
46
+
|> Jsont.Object.mem "invite_only" Jsont.bool ~enc:invite_only
47
+
|> Jsont.Object.mem "history_public_to_subscribers" Jsont.bool ~enc:history_public_to_subscribers
48
+
|> Jsont.Object.finish
49
+
```
50
+
51
+
### 2. **Encode Module: Separation of Encoding Concerns**
52
+
53
+
The `Encode` module provides clean utilities for converting between OCaml types and wire formats:
54
+
55
+
```ocaml
56
+
(** Convert using a jsont codec *)
57
+
val to_json_string : 'a Jsont.t -> 'a -> string
58
+
val to_form_urlencoded : 'a Jsont.t -> 'a -> string
59
+
val from_json : 'a Jsont.t -> Jsont.json -> ('a, string) result
60
+
```
61
+
62
+
This eliminates the need for:
63
+
- ❌ Manual JSON tree walking
64
+
- ❌ Round-trip encode→decode conversions
65
+
- ❌ Per-type encoding functions
66
+
67
+
### 3. **Request/Response Types with Codecs**
68
+
69
+
API operations define request/response types locally with their codecs:
70
+
71
+
```ocaml
72
+
(* In channels.ml *)
73
+
module Subscribe_request = struct
74
+
type t = { subscriptions : string list }
75
+
76
+
let codec =
77
+
Jsont.Object.(
78
+
map ~kind:"SubscribeRequest" (fun subscriptions -> { subscriptions })
79
+
|> mem "subscriptions" (Jsont.list Jsont.string) ~enc:(fun r -> r.subscriptions)
80
+
|> finish
81
+
)
82
+
end
83
+
84
+
let subscribe client ~channels =
85
+
let req = Subscribe_request.{ subscriptions = channels } in
86
+
let body = Encode.to_form_urlencoded Subscribe_request.codec req in
87
+
let content_type = "application/x-www-form-urlencoded" in
88
+
match Client.request client ~method_:`POST ~path:"/api/v1/users/me/subscriptions"
89
+
~body ~content_type () with
90
+
| Ok _json -> Ok ()
91
+
| Error err -> Error err
92
+
```
93
+
94
+
### 4. **Type-Safe Decoding**
95
+
96
+
Response parsing uses codecs directly instead of manual pattern matching:
97
+
98
+
```ocaml
99
+
(* OLD - manual JSON walking *)
100
+
match json with
101
+
| Jsont.Object (fields, _) ->
102
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
103
+
(match List.assoc_opt "streams" assoc with
104
+
| Some (Jsont.Array (channel_list, _)) -> ...
105
+
106
+
(* NEW - type-safe codec *)
107
+
let response_codec =
108
+
Jsont.Object.(
109
+
map ~kind:"StreamsResponse" (fun streams -> streams)
110
+
|> mem "streams" (Jsont.list Channel.jsont) ~enc:(fun x -> x)
111
+
|> finish
112
+
)
113
+
in
114
+
match Encode.from_json response_codec json with
115
+
| Ok channels -> Ok channels
116
+
| Error msg -> Error (...)
117
+
```
118
+
119
+
## Benefits
120
+
121
+
### ✅ Type Safety
122
+
- Jsont codecs ensure correct JSON structure
123
+
- Compilation errors catch schema mismatches
124
+
- No runtime type confusion
125
+
126
+
### ✅ Maintainability
127
+
- Protocol changes only require updating codecs
128
+
- No manual JSON manipulation scattered through code
129
+
- Clear separation of concerns
130
+
131
+
### ✅ Reusability
132
+
- Codecs can be composed and reused
133
+
- Encode module works for any jsont-encoded type
134
+
- Request/response types are self-documenting
135
+
136
+
### ✅ Testability
137
+
- Easy to test encoding/decoding in isolation
138
+
- Mock responses can be type-checked
139
+
- Round-trip property testing possible
140
+
141
+
## Migration Pattern
142
+
143
+
When adding new API endpoints:
144
+
145
+
1. **Define the protocol type with codec**:
146
+
```ocaml
147
+
type my_request = { field1: string; field2: int }
148
+
149
+
let my_request_codec =
150
+
Jsont.Object.(
151
+
map ~kind:"MyRequest" (fun field1 field2 -> { field1; field2 })
152
+
|> mem "field1" Jsont.string ~enc:(fun r -> r.field1)
153
+
|> mem "field2" Jsont.int ~enc:(fun r -> r.field2)
154
+
|> finish
155
+
)
156
+
```
157
+
158
+
2. **Encode using Encode module**:
159
+
```ocaml
160
+
let body = Encode.to_form_urlencoded my_request_codec req in
161
+
(* or *)
162
+
let json = Encode.to_json_string my_request_codec req in
163
+
```
164
+
165
+
3. **Decode responses with codec**:
166
+
```ocaml
167
+
match Client.request client ~method_:`POST ~path:"/api/..." ~body () with
168
+
| Ok json ->
169
+
(match Encode.from_json response_codec json with
170
+
| Ok data -> Ok data
171
+
| Error msg -> Error ...)
172
+
```
173
+
174
+
## Comparison with Old Approach
175
+
176
+
### Old (Manual JSON Manipulation):
177
+
```ocaml
178
+
let send client message =
179
+
let json = Message.to_json message in (* Round-trip conversion *)
180
+
let params = match json with
181
+
| Jsont.Object (fields, _) -> (* Manual pattern matching *)
182
+
List.fold_left (fun acc ((key, _), value) ->
183
+
let str_value = match value with (* More pattern matching *)
184
+
| Jsont.String (s, _) -> s
185
+
| Jsont.Bool (true, _) -> "true"
186
+
| _ -> ""
187
+
in
188
+
(key, str_value) :: acc
189
+
) [] fields
190
+
| _ -> [] in
191
+
(* ... *)
192
+
```
193
+
194
+
### New (Codec-Based):
195
+
```ocaml
196
+
let send client message =
197
+
let body = Message.to_form_urlencoded message in (* Clean encoding *)
198
+
let content_type = "application/x-www-form-urlencoded" in
199
+
match Client.request client ~method_:`POST ~path:"/api/v1/messages"
200
+
~body ~content_type () with
201
+
| Ok response -> Message_response.of_json response
202
+
| Error err -> Error err
203
+
```
204
+
205
+
## Future Enhancements
206
+
207
+
- **Validation**: Add validation layers on top of codecs
208
+
- **Versioning**: Support multiple API versions with codec variants
209
+
- **Documentation**: Generate API docs from codec definitions
210
+
- **Testing**: Property-based testing with codec round-trips
211
+
- **Code Generation**: Consider generating codecs from OpenAPI specs
212
+
213
+
## References
214
+
215
+
- Jsont library: https://erratique.ch/software/jsont
216
+
- Zulip REST API: https://zulip.com/api/rest
217
+
- Original design doc: `CLAUDE.md`
-689
stack/zulip/CLAUDE.md
-689
stack/zulip/CLAUDE.md
···
1
-
I would like to build high quality OCaml bindings to the Zulip REST API,
2
-
documented at https://zulip.com/api/rest. As another reference, the Python
3
-
`zulip` library from pip is well maintained.
4
-
5
-
My target is to use the OCaml EIO direct-style library, with an idiomatic as
6
-
possible API that implements it. For JSON parsing, using the jsonm library is
7
-
right. For HTTPS, use cohttp-eio with the tls-eio library. You have access to
8
-
an OCaml LSP via MCP which provides type hints and other language server
9
-
features after you complete a `dune build`.
10
-
11
-
# OCaml Zulip Library Design
12
-
13
-
Based on analysis of:
14
-
- Zulip REST API documentation: https://zulip.com/api/rest
15
-
- Python zulip library: https://github.com/zulip/python-zulip-api
16
-
- Zulip error handling: https://zulip.com/api/rest-error-handling
17
-
- Zulip send message API: https://zulip.com/api/send-message
18
-
19
-
## Overview
20
-
The library follows OCaml best practices with abstract types (`type t`) per module, comprehensive constructors/accessors, and proper pretty printers. Each core concept gets its own module with a clean interface.
21
-
22
-
## Module Structure
23
-
24
-
### Authentication (`Zulip.Auth`)
25
-
```ocaml
26
-
type t (* abstract *)
27
-
28
-
val create : server_url:string -> email:string -> api_key:string -> t
29
-
val from_zuliprc : ?path:string -> unit -> (t, Error.t) result
30
-
val server_url : t -> string
31
-
val email : t -> string
32
-
val to_basic_auth_header : t -> string
33
-
val pp : Format.formatter -> t -> unit
34
-
```
35
-
36
-
### Error Handling (`Zulip.Error`)
37
-
```ocaml
38
-
type code =
39
-
| Invalid_api_key
40
-
| Request_variable_missing
41
-
| Bad_request
42
-
| User_deactivated
43
-
| Realm_deactivated
44
-
| Rate_limit_hit
45
-
| Other of string
46
-
47
-
type t (* abstract *)
48
-
49
-
val create : code:code -> msg:string -> ?extra:(string * Jsonm.value) list -> unit -> t
50
-
val code : t -> code
51
-
val message : t -> string
52
-
val extra : t -> (string * Jsonm.value) list
53
-
val pp : Format.formatter -> t -> unit
54
-
val of_json : Jsonm.value -> t option
55
-
```
56
-
57
-
### Message Types (`Zulip.Message_type`)
58
-
```ocaml
59
-
type t = [ `Direct | `Channel ]
60
-
61
-
val to_string : t -> string
62
-
val of_string : string -> t option
63
-
val pp : Format.formatter -> t -> unit
64
-
```
65
-
66
-
### Message (`Zulip.Message`)
67
-
```ocaml
68
-
type t (* abstract *)
69
-
70
-
val create :
71
-
type_:Message_type.t ->
72
-
to_:string list ->
73
-
content:string ->
74
-
?topic:string ->
75
-
?queue_id:string ->
76
-
?local_id:string ->
77
-
?read_by_sender:bool ->
78
-
unit -> t
79
-
80
-
val type_ : t -> Message_type.t
81
-
val to_ : t -> string list
82
-
val content : t -> string
83
-
val topic : t -> string option
84
-
val queue_id : t -> string option
85
-
val local_id : t -> string option
86
-
val read_by_sender : t -> bool
87
-
val to_json : t -> Jsonm.value
88
-
val pp : Format.formatter -> t -> unit
89
-
```
90
-
91
-
### Message Response (`Zulip.Message_response`)
92
-
```ocaml
93
-
type t (* abstract *)
94
-
95
-
val id : t -> int
96
-
val automatic_new_visibility_policy : t -> string option
97
-
val of_json : Jsonm.value -> (t, Error.t) result
98
-
val pp : Format.formatter -> t -> unit
99
-
```
100
-
101
-
### Client (`Zulip.Client`)
102
-
```ocaml
103
-
type t (* abstract *)
104
-
105
-
val create : #Eio.Env.t -> Auth.t -> t
106
-
val with_client : #Eio.Env.t -> Auth.t -> (t -> 'a) -> 'a
107
-
108
-
val request :
109
-
t ->
110
-
method_:[`GET | `POST | `PUT | `DELETE | `PATCH] ->
111
-
path:string ->
112
-
?params:(string * string) list ->
113
-
?body:string ->
114
-
unit ->
115
-
(Jsonm.value, Error.t) result
116
-
```
117
-
118
-
### Messages (`Zulip.Messages`)
119
-
```ocaml
120
-
val send : Client.t -> Message.t -> (Message_response.t, Error.t) result
121
-
val edit : Client.t -> message_id:int -> ?content:string -> ?topic:string -> unit -> (unit, Error.t) result
122
-
val delete : Client.t -> message_id:int -> (unit, Error.t) result
123
-
val get : Client.t -> message_id:int -> (Jsonm.value, Error.t) result
124
-
val get_messages :
125
-
Client.t ->
126
-
?anchor:string ->
127
-
?num_before:int ->
128
-
?num_after:int ->
129
-
?narrow:string list ->
130
-
unit ->
131
-
(Jsonm.value, Error.t) result
132
-
```
133
-
134
-
### Channel (`Zulip.Channel`)
135
-
```ocaml
136
-
type t (* abstract *)
137
-
138
-
val create :
139
-
name:string ->
140
-
description:string ->
141
-
?invite_only:bool ->
142
-
?history_public_to_subscribers:bool ->
143
-
unit -> t
144
-
145
-
val name : t -> string
146
-
val description : t -> string
147
-
val invite_only : t -> bool
148
-
val history_public_to_subscribers : t -> bool
149
-
val to_json : t -> Jsonm.value
150
-
val of_json : Jsonm.value -> (t, Error.t) result
151
-
val pp : Format.formatter -> t -> unit
152
-
```
153
-
154
-
### Channels (`Zulip.Channels`)
155
-
```ocaml
156
-
val create_channel : Client.t -> Channel.t -> (unit, Error.t) result
157
-
val delete : Client.t -> name:string -> (unit, Error.t) result
158
-
val list : Client.t -> (Channel.t list, Error.t) result
159
-
val subscribe : Client.t -> channels:string list -> (unit, Error.t) result
160
-
val unsubscribe : Client.t -> channels:string list -> (unit, Error.t) result
161
-
```
162
-
163
-
### User (`Zulip.User`)
164
-
```ocaml
165
-
type t (* abstract *)
166
-
167
-
val create :
168
-
email:string ->
169
-
full_name:string ->
170
-
?is_active:bool ->
171
-
?is_admin:bool ->
172
-
?is_bot:bool ->
173
-
unit -> t
174
-
175
-
val email : t -> string
176
-
val full_name : t -> string
177
-
val is_active : t -> bool
178
-
val is_admin : t -> bool
179
-
val is_bot : t -> bool
180
-
val to_json : t -> Jsonm.value
181
-
val of_json : Jsonm.value -> (t, Error.t) result
182
-
val pp : Format.formatter -> t -> unit
183
-
```
184
-
185
-
### Users (`Zulip.Users`)
186
-
```ocaml
187
-
val list : Client.t -> (User.t list, Error.t) result
188
-
val get : Client.t -> email:string -> (User.t, Error.t) result
189
-
val create_user : Client.t -> email:string -> full_name:string -> (unit, Error.t) result
190
-
val deactivate : Client.t -> email:string -> (unit, Error.t) result
191
-
```
192
-
193
-
### Event Type (`Zulip.Event_type`)
194
-
```ocaml
195
-
type t =
196
-
| Message
197
-
| Subscription
198
-
| User_activity
199
-
| Other of string
200
-
201
-
val to_string : t -> string
202
-
val of_string : string -> t
203
-
val pp : Format.formatter -> t -> unit
204
-
```
205
-
206
-
### Event (`Zulip.Event`)
207
-
```ocaml
208
-
type t (* abstract *)
209
-
210
-
val id : t -> int
211
-
val type_ : t -> Event_type.t
212
-
val data : t -> Jsonm.value
213
-
val of_json : Jsonm.value -> (t, Error.t) result
214
-
val pp : Format.formatter -> t -> unit
215
-
```
216
-
217
-
### Event Queue (`Zulip.Event_queue`)
218
-
```ocaml
219
-
type t (* abstract *)
220
-
221
-
val register :
222
-
Client.t ->
223
-
?event_types:Event_type.t list ->
224
-
unit ->
225
-
(t, Error.t) result
226
-
227
-
val id : t -> string
228
-
val get_events : t -> Client.t -> ?last_event_id:int -> unit -> (Event.t list, Error.t) result
229
-
val delete : t -> Client.t -> (unit, Error.t) result
230
-
val pp : Format.formatter -> t -> unit
231
-
```
232
-
233
-
## EIO Bot Framework Extension
234
-
235
-
Based on analysis of the Python bot framework at:
236
-
- https://github.com/zulip/python-zulip-api/blob/main/zulip_bots/zulip_bots/lib.py
237
-
- https://github.com/zulip/python-zulip-api/blob/main/zulip_botserver/zulip_botserver/server.py
238
-
239
-
### Bot Handler (`Zulip.Bot`)
240
-
```ocaml
241
-
module Storage : sig
242
-
type t (* abstract *)
243
-
244
-
val create : Client.t -> t
245
-
val get : t -> key:string -> string option
246
-
val put : t -> key:string -> value:string -> unit
247
-
val contains : t -> key:string -> bool
248
-
end
249
-
250
-
module Identity : sig
251
-
type t (* abstract *)
252
-
253
-
val full_name : t -> string
254
-
val email : t -> string
255
-
val mention_name : t -> string
256
-
end
257
-
258
-
type handler = {
259
-
handle_message :
260
-
client:Client.t ->
261
-
message:Jsonm.value ->
262
-
response:(Message.t -> unit) ->
263
-
unit;
264
-
265
-
usage : unit -> string;
266
-
description : unit -> string;
267
-
}
268
-
269
-
type t (* abstract *)
270
-
271
-
val create :
272
-
Client.t ->
273
-
handler:handler ->
274
-
?storage:Storage.t ->
275
-
unit -> t
276
-
277
-
val identity : t -> Identity.t
278
-
val storage : t -> Storage.t
279
-
val handle_message : t -> Jsonm.value -> unit
280
-
val send_reply : t -> original_message:Jsonm.value -> content:string -> unit
281
-
val send_message : t -> Message.t -> unit
282
-
```
283
-
284
-
### Bot Server (`Zulip.Bot_server`)
285
-
```ocaml
286
-
module Config : sig
287
-
type bot_config = {
288
-
email : string;
289
-
api_key : string;
290
-
token : string; (* webhook token *)
291
-
server_url : string;
292
-
module_name : string;
293
-
}
294
-
295
-
type t (* abstract *)
296
-
297
-
val create : bot_configs:bot_config list -> ?host:string -> ?port:int -> unit -> t
298
-
val from_file : string -> (t, Error.t) result
299
-
val from_env : string -> (t, Error.t) result
300
-
val host : t -> string
301
-
val port : t -> int
302
-
val bot_configs : t -> bot_config list
303
-
end
304
-
305
-
type t (* abstract *)
306
-
307
-
val create : #Eio.Env.t -> Config.t -> (t, Error.t) result
308
-
309
-
val run : t -> unit
310
-
(* Starts the server using EIO structured concurrency *)
311
-
312
-
val with_server : #Eio.Env.t -> Config.t -> (t -> 'a) -> ('a, Error.t) result
313
-
(* Resource-safe server management *)
314
-
```
315
-
316
-
### Bot Registry (`Zulip.Bot_registry`)
317
-
```ocaml
318
-
type bot_module = {
319
-
name : string;
320
-
handler : Bot.handler;
321
-
create_instance : Client.t -> Bot.t;
322
-
}
323
-
324
-
type t (* abstract *)
325
-
326
-
val create : unit -> t
327
-
val register : t -> bot_module -> unit
328
-
val get_handler : t -> email:string -> Bot.t option
329
-
val list_bots : t -> string list
330
-
331
-
(* Dynamic module loading *)
332
-
val load_from_file : string -> (bot_module, Error.t) result
333
-
val load_from_directory : string -> (bot_module list, Error.t) result
334
-
```
335
-
336
-
### Webhook Handler (`Zulip.Webhook`)
337
-
```ocaml
338
-
type webhook_event = {
339
-
bot_email : string;
340
-
token : string;
341
-
message : Jsonm.value;
342
-
trigger : [`Direct_message | `Mention];
343
-
}
344
-
345
-
type response = {
346
-
content : string option;
347
-
message_type : Message_type.t option;
348
-
to_ : string list option;
349
-
topic : string option;
350
-
}
351
-
352
-
val parse_webhook : string -> (webhook_event, Error.t) result
353
-
val handle_webhook : Bot_registry.t -> webhook_event -> (response option, Error.t) result
354
-
```
355
-
356
-
### Structured Concurrency Design
357
-
358
-
The EIO-based server uses structured concurrency to manage multiple bots safely:
359
-
360
-
```ocaml
361
-
(* Example server implementation using EIO *)
362
-
let run_server env config =
363
-
let registry = Bot_registry.create () in
364
-
365
-
(* Load and register all configured bots concurrently *)
366
-
Eio.Switch.run @@ fun sw ->
367
-
368
-
(* Start each bot in its own fiber *)
369
-
List.iter (fun bot_config ->
370
-
Eio.Fiber.fork ~sw (fun () ->
371
-
let auth = Auth.create
372
-
~server_url:bot_config.server_url
373
-
~email:bot_config.email
374
-
~api_key:bot_config.api_key in
375
-
376
-
Client.with_client env auth @@ fun client ->
377
-
378
-
(* Load bot module *)
379
-
match Bot_registry.load_from_file bot_config.module_name with
380
-
| Ok bot_module ->
381
-
let bot = bot_module.create_instance client in
382
-
Bot_registry.register registry bot_module;
383
-
384
-
(* Keep bot alive and handle events *)
385
-
Event_loop.run client bot
386
-
| Error e ->
387
-
Printf.eprintf "Failed to load bot %s: %s\n"
388
-
bot_config.email (Error.message e)
389
-
)
390
-
) (Config.bot_configs config);
391
-
392
-
(* Start HTTP server for webhooks *)
393
-
let server_addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, Config.port config) in
394
-
Eio.Net.run_server env#net server_addr ~on_error:raise @@ fun flow _addr ->
395
-
396
-
(* Handle each webhook request concurrently *)
397
-
Eio.Switch.run @@ fun req_sw ->
398
-
Eio.Fiber.fork ~sw:req_sw (fun () ->
399
-
handle_http_request registry flow
400
-
)
401
-
```
402
-
403
-
### Event Loop (`Zulip.Event_loop`)
404
-
```ocaml
405
-
type t (* abstract *)
406
-
407
-
val create : Client.t -> Bot.t -> t
408
-
409
-
val run : Client.t -> Bot.t -> unit
410
-
(* Runs the event loop using real-time events API *)
411
-
412
-
val run_webhook_mode : Client.t -> Bot.t -> unit
413
-
(* Runs in webhook mode, waiting for HTTP callbacks *)
414
-
415
-
(* For advanced use cases *)
416
-
val with_event_loop :
417
-
Client.t ->
418
-
Bot.t ->
419
-
(Event_queue.t -> unit) ->
420
-
unit
421
-
```
422
-
423
-
## Key EIO Advantages
424
-
425
-
1. **Structured Concurrency**: Each bot runs in its own fiber with proper cleanup
426
-
2. **Resource Safety**: Automatic cleanup of connections, event queues, and HTTP servers
427
-
3. **Backpressure**: Natural flow control through EIO's cooperative scheduling
428
-
4. **Error Isolation**: Bot failures don't crash the entire server
429
-
5. **Graceful Shutdown**: Structured teardown of all resources
430
-
431
-
## Design Principles
432
-
433
-
1. **Abstract Types**: Each major concept has its own module with abstract `type t`
434
-
2. **Constructors**: Clear `create` functions with optional parameters
435
-
3. **Accessors**: All fields accessible via dedicated functions
436
-
4. **Pretty Printing**: Every type has a `pp` function for debugging
437
-
5. **JSON Conversion**: Bidirectional JSON conversion where appropriate
438
-
6. **Error Handling**: Consistent `(_, Error.t) result` return types
439
-
440
-
## Authentication Strategy
441
-
442
-
- Support zuliprc files and direct credential passing
443
-
- Abstract `Auth.t` prevents credential leakage
444
-
- HTTP Basic Auth with proper encoding
445
-
446
-
## EIO Integration
447
-
448
-
- All operations use EIO's direct-style async
449
-
- Resource-safe client management with `with_client`
450
-
- Proper cleanup of connections and event queues
451
-
452
-
## Example Usage
453
-
454
-
### Simple Message Sending
455
-
```ocaml
456
-
let () =
457
-
Eio_main.run @@ fun env ->
458
-
let auth = Zulip.Auth.create
459
-
~server_url:"https://example.zulipchat.com"
460
-
~email:"bot@example.com"
461
-
~api_key:"your-api-key" in
462
-
463
-
Zulip.Client.with_client env auth @@ fun client ->
464
-
465
-
let message = Zulip.Message.create
466
-
~type_:`Channel
467
-
~to_:["general"]
468
-
~content:"Hello from OCaml!"
469
-
~topic:"Bots"
470
-
() in
471
-
472
-
match Zulip.Messages.send client message with
473
-
| Ok response ->
474
-
Printf.printf "Message sent with ID: %d\n"
475
-
(Zulip.Message_response.id response)
476
-
| Error error ->
477
-
Printf.printf "Error: %s\n"
478
-
(Zulip.Error.message error)
479
-
```
480
-
481
-
### Simple Bot
482
-
```ocaml
483
-
let echo_handler = Zulip.Bot.{
484
-
handle_message = (fun ~client ~message ~response ->
485
-
let content = extract_content message in
486
-
let echo_msg = Message.create
487
-
~type_:`Direct
488
-
~to_:[sender_email message]
489
-
~content:("Echo: " ^ content) () in
490
-
response echo_msg
491
-
);
492
-
usage = (fun () -> "Echo bot - repeats your message");
493
-
description = (fun () -> "A simple echo bot");
494
-
}
495
-
496
-
let () =
497
-
Eio_main.run @@ fun env ->
498
-
let auth = Auth.from_zuliprc () |> Result.get_ok in
499
-
500
-
Client.with_client env auth @@ fun client ->
501
-
let bot = Bot.create client ~handler:echo_handler () in
502
-
Event_loop.run client bot
503
-
```
504
-
505
-
### Multi-Bot Server
506
-
```ocaml
507
-
let () =
508
-
Eio_main.run @@ fun env ->
509
-
let config = Bot_server.Config.from_file "bots.conf" |> Result.get_ok in
510
-
511
-
Bot_server.with_server env config @@ fun server ->
512
-
Bot_server.run server
513
-
```
514
-
515
-
## Package Dependencies
516
-
517
-
- `eio` - Effects-based I/O
518
-
- `cohttp-eio` - HTTP client with EIO support
519
-
- `tls-eio` - TLS support for HTTPS
520
-
- `jsonm` - Streaming JSON codec
521
-
- `uri` - URI parsing and manipulation
522
-
- `base64` - Base64 encoding for authentication
523
-
524
-
# Architecture Analysis: zulip_bot vs zulip_botserver
525
-
526
-
## Library Separation
527
-
528
-
### `zulip_bot` - Individual Bot Framework
529
-
**Purpose**: Library for building and running a single bot instance
530
-
531
-
**Key Components**:
532
-
- `Bot_handler` - Interface for bot logic with EIO environment access
533
-
- `Bot_runner` - Manages lifecycle of one bot (real-time events or webhook mode)
534
-
- `Bot_config` - Configuration for a single bot
535
-
- `Bot_storage` - Simple in-memory storage for bot state
536
-
537
-
**Usage Pattern**:
538
-
```ocaml
539
-
(* Run a single bot directly *)
540
-
let my_bot = Bot_handler.create (module My_echo_bot) ~config ~storage ~identity in
541
-
let runner = Bot_runner.create ~client ~handler:my_bot in
542
-
Bot_runner.run_realtime runner (* Bot connects to Zulip events API directly *)
543
-
```
544
-
545
-
### `zulip_botserver` - Multi-Bot Server Infrastructure
546
-
**Purpose**: HTTP server that manages multiple bots via webhooks
547
-
548
-
**Key Components**:
549
-
- `Bot_server` - HTTP server receiving webhook events from Zulip
550
-
- `Bot_registry` - Manages multiple bot instances
551
-
- `Server_config` - Configuration for multiple bots + server settings
552
-
- `Webhook_handler` - Parses incoming webhook requests and routes to appropriate bots
553
-
554
-
**Usage Pattern**:
555
-
```ocaml
556
-
(* Run a server hosting multiple bots *)
557
-
let registry = Bot_registry.create () in
558
-
Bot_registry.register registry echo_bot_module;
559
-
Bot_registry.register registry weather_bot_module;
560
-
561
-
let server = Bot_server.create ~env ~config ~registry in
562
-
Bot_server.run server (* HTTP server waits for webhook calls *)
563
-
```
564
-
565
-
## EIO Environment Requirements
566
-
567
-
### Why Bot Handlers Need Direct EIO Access
568
-
569
-
Bot handlers require direct access to the EIO environment for legitimate I/O operations beyond HTTP requests to Zulip:
570
-
571
-
1. **Network Operations**: Custom HTTP requests, API calls to external services
572
-
2. **File System Operations**: Reading configuration files, CSV dictionaries, logs
573
-
3. **Resource Management**: Proper cleanup via structured concurrency
574
-
575
-
### Example: URL Checker Bot
576
-
```ocaml
577
-
module Url_checker_bot : Zulip_bot.Bot_handler.Bot_handler = struct
578
-
let handle_message ~config ~storage ~identity ~message ~env =
579
-
match parse_command message with
580
-
| "!check", url ->
581
-
(* Direct EIO network access needed *)
582
-
Eio.Switch.run @@ fun sw ->
583
-
let client = Cohttp_eio.Client.make ~sw env#net in
584
-
let response = Cohttp_eio.Client.head ~sw client (Uri.of_string url) in
585
-
let status = Cohttp.Code.code_of_status response.status in
586
-
Ok (Response.reply ~content:(format_status_message url status))
587
-
| _ -> Ok Response.none
588
-
end
589
-
```
590
-
591
-
### Example: CSV Dictionary Bot
592
-
```ocaml
593
-
module Csv_dict_bot : Zulip_bot.Bot_handler.Bot_handler = struct
594
-
let handle_message ~config ~storage ~identity ~message ~env =
595
-
match parse_command message with
596
-
| "!lookup", term ->
597
-
(* Direct EIO file system access needed *)
598
-
let csv_path = Bot_config.get_required config ~key:"csv_file" in
599
-
let content = Eio.Path.load env#fs (Eio.Path.parse csv_path) in
600
-
let matches = search_csv_content content term in
601
-
Ok (Response.reply ~content:(format_matches matches))
602
-
| _ -> Ok Response.none
603
-
end
604
-
```
605
-
606
-
## Refined Bot Handler Interface
607
-
608
-
Based on analysis, the current EIO environment plumbing is **essential** and should be cleaned up:
609
-
610
-
```ocaml
611
-
(** Clean bot handler interface with direct EIO access *)
612
-
module type Bot_handler = sig
613
-
val initialize : Bot_config.t -> (unit, Zulip.Error.t) result
614
-
val usage : unit -> string
615
-
val description : unit -> string
616
-
617
-
(** Handle message with full EIO environment access *)
618
-
val handle_message :
619
-
config:Bot_config.t ->
620
-
storage:Bot_storage.t ->
621
-
identity:Identity.t ->
622
-
message:Message_context.t ->
623
-
env:#Eio.Env.t -> (* Essential for custom I/O *)
624
-
(Response.t, Zulip.Error.t) result
625
-
end
626
-
627
-
type t
628
-
629
-
(** Single creation interface *)
630
-
val create :
631
-
(module Bot_handler) ->
632
-
config:Bot_config.t ->
633
-
storage:Bot_storage.t ->
634
-
identity:Identity.t ->
635
-
t
636
-
637
-
(** Single message handler requiring EIO environment *)
638
-
val handle_message : t -> #Eio.Env.t -> Message_context.t -> (Response.t, Zulip.Error.t) result
639
-
```
640
-
641
-
## Storage Strategy
642
-
643
-
Bot storage can be simplified to in-memory key-value storage since it's server-side:
644
-
645
-
```ocaml
646
-
(* In zulip_bot - storage per bot instance *)
647
-
module Bot_storage = struct
648
-
type t = (string, string) Hashtbl.t (* Simple in-memory key-value *)
649
-
650
-
let create () = Hashtbl.create 16
651
-
let get t ~key = Hashtbl.find_opt t key
652
-
let put t ~key ~value = Hashtbl.replace t key value
653
-
let contains t ~key = Hashtbl.mem t key
654
-
end
655
-
656
-
(* In zulip_botserver - storage shared across bots *)
657
-
module Server_storage = struct
658
-
type t = (string * string, string) Hashtbl.t (* (bot_email, key) -> value *)
659
-
660
-
let create () = Hashtbl.create 64
661
-
let get t ~bot_email ~key = Hashtbl.find_opt t (bot_email, key)
662
-
let put t ~bot_email ~key ~value = Hashtbl.replace t (bot_email, key) value
663
-
end
664
-
```
665
-
666
-
## Interface Cleanup Recommendations
667
-
668
-
1. **Remove** the problematic `handle_message` function with mock environment
669
-
2. **Keep** `handle_message_with_env` but rename to `handle_message`
670
-
3. **Use** `#Eio.Env.t` constraint for clean typing
671
-
4. **Document** that bot handlers have full EIO access for custom I/O operations
672
-
673
-
This design maintains flexibility for real-world bot functionality while providing clean, type-safe interfaces.
674
-
675
-
## Sources and References
676
-
677
-
This design is based on comprehensive analysis of:
678
-
679
-
1. **Zulip REST API Documentation**:
680
-
- Main API: https://zulip.com/api/rest
681
-
- Error Handling: https://zulip.com/api/rest-error-handling
682
-
- Send Message: https://zulip.com/api/send-message
683
-
684
-
2. **Python Zulip Library**:
685
-
- Main repository: https://github.com/zulip/python-zulip-api
686
-
- Bot framework: https://github.com/zulip/python-zulip-api/blob/main/zulip_bots/zulip_bots/lib.py
687
-
- Bot server: https://github.com/zulip/python-zulip-api/blob/main/zulip_botserver/zulip_botserver/server.py
688
-
689
-
The design adapts these Python patterns to idiomatic OCaml with abstract types, proper error handling, and EIO's structured concurrency for robust, type-safe Zulip integration.
+2
-2
stack/zulip/dune-project
+2
-2
stack/zulip/dune-project
···
2
2
3
3
(name ocaml-zulip)
4
4
5
+
(generate_opam_files true)
6
+
5
7
(package
6
8
(name zulip)
7
9
(synopsis "OCaml bindings for the Zulip REST API")
···
11
13
dune
12
14
eio
13
15
requests
14
-
ezjsonm
15
16
uri
16
17
base64
17
18
(alcotest :with-test)
···
26
27
dune
27
28
zulip
28
29
eio
29
-
ezjsonm
30
30
(alcotest :with-test)))
31
31
32
32
(package
+2
-5
stack/zulip/examples/example.ml
+2
-5
stack/zulip/examples/example.ml
···
31
31
(match Message.topic message with Some t -> t | None -> "None");
32
32
33
33
(* Test JSON serialization *)
34
-
let json = Message.to_json message in
35
-
Printf.printf "\nMessage JSON: %s\n"
36
-
(match json with
37
-
| `O _ -> "JSON object (serialized correctly)"
38
-
| _ -> "Invalid JSON");
34
+
let json_str = Message.to_json_string message in
35
+
Printf.printf "\nMessage JSON: %s\n" json_str;
39
36
40
37
(* Create client *)
41
38
let client = Client.create ~sw env auth in
+4
-3
stack/zulip/examples/test_client.ml
+4
-3
stack/zulip/examples/test_client.ml
···
48
48
| Ok json ->
49
49
Printf.printf "Fetched messages successfully!\n";
50
50
(match json with
51
-
| `O fields ->
52
-
(match List.assoc_opt "messages" fields with
53
-
| Some (`A messages) ->
51
+
| Jsont.Object (fields, _) ->
52
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
53
+
(match List.assoc_opt "messages" assoc with
54
+
| Some (Jsont.Array (messages, _)) ->
54
55
Printf.printf "Got %d messages\n" (List.length messages)
55
56
| _ -> Printf.printf "No messages field found\n")
56
57
| _ -> Printf.printf "Unexpected JSON format\n")
+25
-33
stack/zulip/lib/zulip/lib/channel.ml
+25
-33
stack/zulip/lib/zulip/lib/channel.ml
···
13
13
let invite_only t = t.invite_only
14
14
let history_public_to_subscribers t = t.history_public_to_subscribers
15
15
16
-
let to_json t =
17
-
`O [
18
-
("name", `String t.name);
19
-
("description", `String t.description);
20
-
("invite_only", `Bool t.invite_only);
21
-
("history_public_to_subscribers", `Bool t.history_public_to_subscribers);
22
-
]
16
+
let pp fmt t = Format.fprintf fmt "Channel{name=%s, description=%s}" t.name t.description
23
17
24
-
let of_json json =
25
-
try
26
-
match json with
27
-
| `O fields ->
28
-
let get_string key =
29
-
match List.assoc key fields with
30
-
| `String s -> s
31
-
| _ -> failwith ("Expected string for " ^ key) in
32
-
let get_bool key default =
33
-
match List.assoc_opt key fields with
34
-
| Some (`Bool b) -> b
35
-
| None -> default
36
-
| _ -> failwith ("Expected bool for " ^ key) in
37
-
38
-
let name = get_string "name" in
39
-
let description = get_string "description" in
40
-
let invite_only = get_bool "invite_only" false in
41
-
let history_public_to_subscribers = get_bool "history_public_to_subscribers" true in
42
-
43
-
Ok { name; description; invite_only; history_public_to_subscribers }
44
-
| _ ->
45
-
Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:"Channel JSON must be an object" ())
46
-
with
47
-
| exn ->
48
-
Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:("Channel JSON parsing failed: " ^ Printexc.to_string exn) ())
18
+
(* Jsont codec for channel *)
19
+
let jsont =
20
+
let kind = "Channel" in
21
+
let doc = "A Zulip channel (stream)" in
22
+
let make name description invite_only history_public_to_subscribers =
23
+
{ name; description; invite_only; history_public_to_subscribers }
24
+
in
25
+
Jsont.Object.map ~kind ~doc make
26
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
27
+
|> Jsont.Object.mem "description" Jsont.string ~enc:description
28
+
|> Jsont.Object.mem "invite_only" Jsont.bool ~enc:invite_only
29
+
|> Jsont.Object.mem "history_public_to_subscribers" Jsont.bool ~enc:history_public_to_subscribers
30
+
|> Jsont.Object.finish
31
+
32
+
(* Decode and encode functions using Encode module *)
33
+
let of_json json =
34
+
match Encode.from_json jsont json with
35
+
| Ok v -> Ok v
36
+
| Error msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg ())
37
+
38
+
let to_json_string t =
39
+
Encode.to_json_string jsont t
49
40
50
-
let pp fmt t = Format.fprintf fmt "Channel{name=%s, description=%s}" t.name t.description
41
+
let to_form_urlencoded t =
42
+
Encode.to_form_urlencoded jsont t
+17
-6
stack/zulip/lib/zulip/lib/channel.mli
+17
-6
stack/zulip/lib/zulip/lib/channel.mli
···
1
1
type t
2
2
3
-
val create :
4
-
name:string ->
5
-
description:string ->
6
-
?invite_only:bool ->
7
-
?history_public_to_subscribers:bool ->
3
+
val create :
4
+
name:string ->
5
+
description:string ->
6
+
?invite_only:bool ->
7
+
?history_public_to_subscribers:bool ->
8
8
unit -> t
9
9
10
10
val name : t -> string
11
11
val description : t -> string
12
12
val invite_only : t -> bool
13
13
val history_public_to_subscribers : t -> bool
14
-
val to_json : t -> Zulip_types.json
14
+
15
+
(** Jsont codec for the channel type *)
16
+
val jsont : t Jsont.t
17
+
18
+
(** Decode from Jsont.json *)
15
19
val of_json : Zulip_types.json -> (t, Zulip_types.zerror) result
20
+
21
+
(** Encode to JSON string *)
22
+
val to_json_string : t -> string
23
+
24
+
(** Encode to form-urlencoded string *)
25
+
val to_form_urlencoded : t -> string
26
+
16
27
val pp : Format.formatter -> t -> unit
+53
-43
stack/zulip/lib/zulip/lib/channels.ml
+53
-43
stack/zulip/lib/zulip/lib/channels.ml
···
1
-
let create_channel client channel =
2
-
let body = match Channel.to_json channel with
3
-
| `O fields ->
4
-
String.concat "&" (List.map (fun (k, v) ->
5
-
match v with
6
-
| `String s -> k ^ "=" ^ Uri.pct_encode s
7
-
| `Bool b -> k ^ "=" ^ string_of_bool b
8
-
| _ -> ""
9
-
) fields)
10
-
| _ -> "" in
11
-
match Client.request client ~method_:`POST ~path:"/api/v1/streams" ~body () with
1
+
let create_channel client channel =
2
+
let body = Channel.to_form_urlencoded channel in
3
+
let content_type = "application/x-www-form-urlencoded" in
4
+
match Client.request client ~method_:`POST ~path:"/api/v1/streams" ~body ~content_type () with
12
5
| Ok _json -> Ok ()
13
6
| Error err -> Error err
14
7
15
-
let delete client ~name =
8
+
let delete client ~name =
16
9
let encoded_name = Uri.pct_encode name in
17
10
match Client.request client ~method_:`DELETE ~path:("/api/v1/streams/" ^ encoded_name) () with
18
11
| Ok _json -> Ok ()
19
12
| Error err -> Error err
20
13
21
-
let list client =
14
+
let list client =
15
+
(* Define response codec *)
16
+
let response_codec =
17
+
Jsont.Object.(
18
+
map ~kind:"StreamsResponse" (fun streams -> streams)
19
+
|> mem "streams" (Jsont.list Channel.jsont) ~enc:(fun x -> x)
20
+
|> finish
21
+
)
22
+
in
23
+
22
24
match Client.request client ~method_:`GET ~path:"/api/v1/streams" () with
23
-
| Ok json ->
24
-
(match json with
25
-
| `O fields ->
26
-
(match List.assoc_opt "streams" fields with
27
-
| Some (`A channel_list) ->
28
-
let channels = List.fold_left (fun acc channel_json ->
29
-
match Channel.of_json channel_json with
30
-
| Ok channel -> channel :: acc
31
-
| Error _ -> acc
32
-
) [] channel_list in
33
-
Ok (List.rev channels)
34
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid streams response format" ()))
35
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Streams response must be an object" ()))
25
+
| Ok json ->
26
+
(match Encode.from_json response_codec json with
27
+
| Ok channels -> Ok channels
28
+
| Error msg -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))
36
29
| Error err -> Error err
37
30
38
-
let subscribe client ~channels =
39
-
let channels_json = `A (List.map (fun name -> `String name) channels) in
40
-
let body = "subscriptions=" ^ (match channels_json with
41
-
| `A items -> "[" ^ String.concat "," (List.map (function
42
-
| `String s -> "\"" ^ s ^ "\""
43
-
| _ -> "") items) ^ "]"
44
-
| _ -> "[]") in
45
-
match Client.request client ~method_:`POST ~path:"/api/v1/users/me/subscriptions" ~body () with
31
+
(* Request types with jsont codecs *)
32
+
module Subscribe_request = struct
33
+
type t = { subscriptions : string list }
34
+
35
+
let codec =
36
+
Jsont.Object.(
37
+
map ~kind:"SubscribeRequest" (fun subscriptions -> { subscriptions })
38
+
|> mem "subscriptions" (Jsont.list Jsont.string) ~enc:(fun r -> r.subscriptions)
39
+
|> finish
40
+
)
41
+
end
42
+
43
+
module Unsubscribe_request = struct
44
+
type t = { delete : string list }
45
+
46
+
let codec =
47
+
Jsont.Object.(
48
+
map ~kind:"UnsubscribeRequest" (fun delete -> { delete })
49
+
|> mem "delete" (Jsont.list Jsont.string) ~enc:(fun r -> r.delete)
50
+
|> finish
51
+
)
52
+
end
53
+
54
+
let subscribe client ~channels =
55
+
let req = Subscribe_request.{ subscriptions = channels } in
56
+
let body = Encode.to_form_urlencoded Subscribe_request.codec req in
57
+
let content_type = "application/x-www-form-urlencoded" in
58
+
match Client.request client ~method_:`POST ~path:"/api/v1/users/me/subscriptions" ~body ~content_type () with
46
59
| Ok _json -> Ok ()
47
60
| Error err -> Error err
48
61
49
-
let unsubscribe client ~channels =
50
-
let channels_json = `A (List.map (fun name -> `String name) channels) in
51
-
let body = "delete=" ^ (match channels_json with
52
-
| `A items -> "[" ^ String.concat "," (List.map (function
53
-
| `String s -> "\"" ^ s ^ "\""
54
-
| _ -> "") items) ^ "]"
55
-
| _ -> "[]") in
56
-
match Client.request client ~method_:`DELETE ~path:"/api/v1/users/me/subscriptions" ~body () with
62
+
let unsubscribe client ~channels =
63
+
let req = Unsubscribe_request.{ delete = channels } in
64
+
let body = Encode.to_form_urlencoded Unsubscribe_request.codec req in
65
+
let content_type = "application/x-www-form-urlencoded" in
66
+
match Client.request client ~method_:`DELETE ~path:"/api/v1/users/me/subscriptions" ~body ~content_type () with
57
67
| Ok _json -> Ok ()
58
-
| Error err -> Error err
68
+
| Error err -> Error err
+16
-14
stack/zulip/lib/zulip/lib/client.ml
+16
-14
stack/zulip/lib/zulip/lib/client.ml
···
85
85
Buffer.contents buf
86
86
in
87
87
88
-
(* Parse JSON response using Ezjsonm *)
88
+
(* Parse JSON response using Jsont_bytesrw *)
89
89
let json =
90
-
try
91
-
Ezjsonm.from_string body_str
92
-
with Ezjsonm.Parse_error (_, msg) ->
93
-
Log.err (fun m -> m "JSON parse error: %s" msg);
94
-
failwith ("JSON parse error: " ^ msg)
90
+
match Jsont_bytesrw.decode_string' Jsont.json body_str with
91
+
| Ok j -> j
92
+
| Error e ->
93
+
let msg = Jsont.Error.to_string e in
94
+
Log.err (fun m -> m "JSON parse error: %s" msg);
95
+
failwith ("JSON parse error: " ^ msg)
95
96
in
96
97
97
98
(* Check for Zulip error response *)
98
99
match json with
99
-
| `O fields ->
100
-
(match List.assoc_opt "result" fields with
101
-
| Some (`String "error") ->
102
-
let msg = match List.assoc_opt "msg" fields with
103
-
| Some (`String s) -> s
100
+
| Jsont.Object (fields, _) ->
101
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
102
+
(match List.assoc_opt "result" assoc with
103
+
| Some (Jsont.String ("error", _)) ->
104
+
let msg = match List.assoc_opt "msg" assoc with
105
+
| Some (Jsont.String (s, _)) -> s
104
106
| _ -> "Unknown error"
105
107
in
106
-
let code = match List.assoc_opt "code" fields with
107
-
| Some (`String s) -> Zulip_types.error_code_of_string s
108
+
let code = match List.assoc_opt "code" assoc with
109
+
| Some (Jsont.String (s, _)) -> Zulip_types.error_code_of_string s
108
110
| _ -> Zulip_types.Other "unknown"
109
111
in
110
112
Log.warn (fun m -> m "API error: %s (code: %s)" msg
···
126
128
~msg:"Invalid JSON response" ()))
127
129
128
130
let pp fmt t =
129
-
Format.fprintf fmt "Client(server=%s)" (Auth.server_url t.auth)
131
+
Format.fprintf fmt "Client(server=%s)" (Auth.server_url t.auth)
+1
-1
stack/zulip/lib/zulip/lib/dune
+1
-1
stack/zulip/lib/zulip/lib/dune
+56
stack/zulip/lib/zulip/lib/encode.ml
+56
stack/zulip/lib/zulip/lib/encode.ml
···
1
+
(** Encoding utilities for Zulip API requests *)
2
+
3
+
(** Convert a jsont-encoded value to JSON string *)
4
+
let to_json_string : 'a Jsont.t -> 'a -> string = fun codec value ->
5
+
match Jsont_bytesrw.encode_string' codec value with
6
+
| Ok s -> s
7
+
| Error e -> failwith ("JSON encoding error: " ^ Jsont.Error.to_string e)
8
+
9
+
(** Convert a jsont-encoded value to form-urlencoded string *)
10
+
let to_form_urlencoded : 'a Jsont.t -> 'a -> string = fun codec value ->
11
+
(* First encode to JSON, then extract fields *)
12
+
let json_str = to_json_string codec value in
13
+
match Jsont_bytesrw.decode_string' Jsont.json json_str with
14
+
| Error e -> failwith ("JSON decode error: " ^ Jsont.Error.to_string e)
15
+
| Ok (Jsont.Object (fields, _)) ->
16
+
(* Convert object fields to form-urlencoded *)
17
+
let encode_value = function
18
+
| Jsont.String (s, _) -> Some (Uri.pct_encode ~component:`Query_value s)
19
+
| Jsont.Bool (b, _) -> Some (string_of_bool b)
20
+
| Jsont.Number (n, _) -> Some (string_of_float n)
21
+
| Jsont.Null _ -> None
22
+
| Jsont.Array (items, _) ->
23
+
(* For arrays, encode as JSON array string *)
24
+
let array_str = "[" ^ String.concat "," (List.filter_map (function
25
+
| Jsont.String (s, _) -> Some ("\"" ^ String.escaped s ^ "\"")
26
+
| Jsont.Number (n, _) -> Some (string_of_float n)
27
+
| Jsont.Bool (b, _) -> Some (string_of_bool b)
28
+
| _ -> None
29
+
) items) ^ "]" in
30
+
Some array_str
31
+
| Jsont.Object _ -> None (* Skip nested objects *)
32
+
in
33
+
34
+
let params = List.filter_map (fun ((key, _), value) ->
35
+
match encode_value value with
36
+
| Some encoded -> Some (key ^ "=" ^ encoded)
37
+
| None -> None
38
+
) fields in
39
+
40
+
String.concat "&" params
41
+
| Ok _ ->
42
+
failwith "Expected JSON object for form encoding"
43
+
44
+
(** Parse JSON string using a jsont codec *)
45
+
let from_json_string : 'a Jsont.t -> string -> ('a, string) result = fun codec json_str ->
46
+
match Jsont_bytesrw.decode_string' codec json_str with
47
+
| Ok v -> Ok v
48
+
| Error e -> Error (Jsont.Error.to_string e)
49
+
50
+
(** Parse a Jsont.json value using a codec *)
51
+
let from_json : 'a Jsont.t -> Jsont.json -> ('a, string) result = fun codec json ->
52
+
let json_str = match Jsont_bytesrw.encode_string' Jsont.json json with
53
+
| Ok s -> s
54
+
| Error e -> failwith ("Failed to re-encode json: " ^ Jsont.Error.to_string e)
55
+
in
56
+
from_json_string codec json_str
+21
stack/zulip/lib/zulip/lib/encode.mli
+21
stack/zulip/lib/zulip/lib/encode.mli
···
1
+
(** Encoding utilities for Zulip API requests *)
2
+
3
+
(** Convert a value to JSON string using its jsont codec *)
4
+
val to_json_string : 'a Jsont.t -> 'a -> string
5
+
6
+
(** Convert a value to application/x-www-form-urlencoded string using its jsont codec
7
+
8
+
The codec should represent a JSON object. Fields will be converted to key=value pairs:
9
+
- Strings: URL-encoded
10
+
- Booleans: "true"/"false"
11
+
- Numbers: string representation
12
+
- Arrays: JSON array string "[...]"
13
+
- Null: omitted
14
+
- Nested objects: omitted *)
15
+
val to_form_urlencoded : 'a Jsont.t -> 'a -> string
16
+
17
+
(** Parse JSON string using a jsont codec *)
18
+
val from_json_string : 'a Jsont.t -> string -> ('a, string) result
19
+
20
+
(** Parse a Jsont.json value using a codec *)
21
+
val from_json : 'a Jsont.t -> Jsont.json -> ('a, string) result
+35
-24
stack/zulip/lib/zulip/lib/event.ml
+35
-24
stack/zulip/lib/zulip/lib/event.ml
···
8
8
let type_ t = t.type_
9
9
let data t = t.data
10
10
11
-
let of_json json =
11
+
let pp fmt t = Format.fprintf fmt "Event{id=%d, type=%a}" t.id Event_type.pp t.type_
12
+
13
+
(* Helper to extract fields from Jsont.json *)
14
+
let get_int_field json name =
15
+
match json with
16
+
| Jsont.Object (fields, _) ->
17
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
18
+
(match List.assoc_opt name assoc with
19
+
| Some (Jsont.Number (n, _)) -> int_of_float n
20
+
| _ -> Jsont.Error.msg Jsont.Meta.none
21
+
(Format.sprintf "Field '%s' not found or not an int" name))
22
+
| _ -> Jsont.Error.msg Jsont.Meta.none "Expected JSON object"
23
+
24
+
let get_string_field json name =
25
+
match json with
26
+
| Jsont.Object (fields, _) ->
27
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
28
+
(match List.assoc_opt name assoc with
29
+
| Some (Jsont.String (s, _)) -> s
30
+
| _ -> Jsont.Error.msg Jsont.Meta.none
31
+
(Format.sprintf "Field '%s' not found or not a string" name))
32
+
| _ -> Jsont.Error.msg Jsont.Meta.none "Expected JSON object"
33
+
34
+
(* Simple decoder that extracts id and type, keeping full JSON as data *)
35
+
let of_json_direct json =
12
36
try
13
-
match json with
14
-
| `O fields ->
15
-
let get_int key =
16
-
match List.assoc key fields with
17
-
| `Float f -> int_of_float f
18
-
| _ -> failwith ("Expected int for " ^ key) in
19
-
let get_string key =
20
-
match List.assoc key fields with
21
-
| `String s -> s
22
-
| _ -> failwith ("Expected string for " ^ key) in
23
-
let id = get_int "id" in
24
-
let type_str = get_string "type" in
25
-
let type_ = Event_type.of_string type_str in
26
-
(* The whole event is the data - store it all *)
27
-
let data = json in
37
+
let id = get_int_field json "id" in
38
+
let type_str = get_string_field json "type" in
39
+
let type_ = Event_type.of_string type_str in
40
+
Ok { id; type_; data = json }
41
+
with e ->
42
+
Error (Zulip_types.create_error ~code:(Other "json_parse_error")
43
+
~msg:("Event JSON parsing failed: " ^ Printexc.to_string e) ())
28
44
29
-
Ok { id; type_; data }
30
-
| _ ->
31
-
Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:"Event JSON must be an object" ())
32
-
with
33
-
| exn ->
34
-
Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:("Event JSON parsing failed: " ^ Printexc.to_string exn) ())
35
-
36
-
let pp fmt t = Format.fprintf fmt "Event{id=%d, type=%a}" t.id Event_type.pp t.type_
45
+
(* Decode function *)
46
+
let of_json json =
47
+
of_json_direct json
+79
-42
stack/zulip/lib/zulip/lib/event_queue.ml
+79
-42
stack/zulip/lib/zulip/lib/event_queue.ml
···
6
6
id : string;
7
7
}
8
8
9
+
(* Request/response codecs *)
10
+
module Register_request = struct
11
+
type t = { event_types : string list option }
12
+
13
+
let codec =
14
+
Jsont.Object.(
15
+
map ~kind:"RegisterRequest" (fun event_types -> { event_types })
16
+
|> opt_mem "event_types" (Jsont.list Jsont.string) ~enc:(fun r -> r.event_types)
17
+
|> finish
18
+
)
19
+
end
20
+
21
+
module Register_response = struct
22
+
type t = { queue_id : string }
23
+
24
+
let codec =
25
+
Jsont.Object.(
26
+
map ~kind:"RegisterResponse" (fun queue_id -> { queue_id })
27
+
|> mem "queue_id" Jsont.string ~enc:(fun r -> r.queue_id)
28
+
|> finish
29
+
)
30
+
end
31
+
9
32
let register client ?event_types () =
10
-
let params = match event_types with
11
-
| None -> []
12
-
| Some types ->
13
-
let types_json = "[" ^
14
-
String.concat "," (List.map (fun t -> "\"" ^ Event_type.to_string t ^ "\"") types) ^
15
-
"]"
16
-
in
17
-
Log.debug (fun m -> m "Registering with event_types: %s" types_json);
18
-
[("event_types", types_json)]
19
-
in
20
-
match Client.request client ~method_:`POST ~path:"/api/v1/register" ~params () with
21
-
| Ok json ->
22
-
(match json with
23
-
| `O fields ->
24
-
(match List.assoc_opt "queue_id" fields with
25
-
| Some (`String queue_id) -> Ok { id = queue_id }
26
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid register response: missing queue_id" ()))
27
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Register response must be an object" ()))
33
+
let event_types_str = Option.map (List.map Event_type.to_string) event_types in
34
+
let req = Register_request.{ event_types = event_types_str } in
35
+
let body = Encode.to_form_urlencoded Register_request.codec req in
36
+
let content_type = "application/x-www-form-urlencoded" in
37
+
38
+
(match event_types_str with
39
+
| Some types -> Log.debug (fun m -> m "Registering with event_types: %s" (String.concat "," types))
40
+
| None -> ());
41
+
42
+
match Client.request client ~method_:`POST ~path:"/api/v1/register" ~body ~content_type () with
43
+
| Ok json ->
44
+
(match Encode.from_json Register_response.codec json with
45
+
| Ok response -> Ok { id = response.queue_id }
46
+
| Error msg -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))
28
47
| Error err -> Error err
29
48
30
49
let id t = t.id
31
50
32
-
let get_events t client ?last_event_id () =
33
-
let params = [("queue_id", t.id)] @
51
+
(* Events response codec - events field is optional (may not be present) *)
52
+
module Events_response = struct
53
+
type t = { events : Event.t list }
54
+
55
+
(* Custom codec that handles Event.t which has its own of_json *)
56
+
let codec =
57
+
let kind = "EventsResponse" in
58
+
let of_string s =
59
+
match Jsont_bytesrw.decode_string' Jsont.json s with
60
+
| Error e -> Error (Jsont.Error.to_string e)
61
+
| Ok (Jsont.Object (fields, _)) ->
62
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
63
+
(match List.assoc_opt "events" assoc with
64
+
| Some (Jsont.Array (event_list, _)) ->
65
+
let events = List.fold_left (fun acc event_json ->
66
+
match Event.of_json event_json with
67
+
| Ok event -> event :: acc
68
+
| Error _ -> acc
69
+
) [] event_list in
70
+
Ok { events = List.rev events }
71
+
| None -> Ok { events = [] }
72
+
| _ -> Error "events field is not an array")
73
+
| Ok _ -> Error "Expected JSON object"
74
+
in
75
+
let enc _t =
76
+
(* Not used for responses, but required by codec *)
77
+
Fmt.str "{\"events\": []}"
78
+
in
79
+
Jsont.of_of_string ~kind of_string ~enc
80
+
end
81
+
82
+
let get_events t client ?last_event_id () =
83
+
let params = [("queue_id", t.id)] @
34
84
(match last_event_id with
35
85
| None -> []
36
86
| Some event_id -> [("last_event_id", string_of_int event_id)]) in
37
87
match Client.request client ~method_:`GET ~path:"/api/v1/events" ~params () with
38
-
| Ok json ->
39
-
(match json with
40
-
| `O fields ->
41
-
(match List.assoc_opt "events" fields with
42
-
| Some (`A event_list) ->
43
-
Log.debug (fun m -> m "Got %d raw events from API" (List.length event_list));
44
-
let events = List.fold_left (fun acc event_json ->
45
-
match Event.of_json event_json with
46
-
| Ok event -> event :: acc
47
-
| Error e ->
48
-
Log.warn (fun m -> m "Failed to parse event: %s" (Zulip_types.error_message e));
49
-
acc
50
-
) [] event_list in
51
-
Ok (List.rev events)
52
-
| Some _other ->
53
-
Log.warn (fun m -> m "Events field is not an array");
54
-
Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid events response format" ())
55
-
| None ->
56
-
Log.debug (fun m -> m "No events field in response");
57
-
Ok [])
58
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Events response must be an object" ()))
88
+
| Ok json ->
89
+
(match Encode.from_json Events_response.codec json with
90
+
| Ok response ->
91
+
Log.debug (fun m -> m "Got %d events from API" (List.length response.events));
92
+
Ok response.events
93
+
| Error msg ->
94
+
Log.warn (fun m -> m "Failed to parse events response: %s" msg);
95
+
Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))
59
96
| Error err -> Error err
60
97
61
-
let delete t client =
98
+
let delete t client =
62
99
let params = [("queue_id", t.id)] in
63
100
match Client.request client ~method_:`DELETE ~path:"/api/v1/events" ~params () with
64
101
| Ok _json -> Ok ()
-206
stack/zulip/lib/zulip/lib/jsonu.ml
-206
stack/zulip/lib/zulip/lib/jsonu.ml
···
1
-
(** JSON utility functions for Zulip API *)
2
-
3
-
type json = Zulip_types.json
4
-
5
-
(** {1 Field extraction utilities} *)
6
-
7
-
let get_string fields key =
8
-
match List.assoc_opt key fields with
9
-
| Some (`String s) -> Ok s
10
-
| Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a string" key) ())
11
-
| None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())
12
-
13
-
let get_string_default fields key default =
14
-
match get_string fields key with
15
-
| Ok s -> s
16
-
| Error _ -> default
17
-
18
-
let get_string_opt fields key =
19
-
match List.assoc_opt key fields with
20
-
| Some (`String s) -> Some s
21
-
| _ -> None
22
-
23
-
let to_int_flex = function
24
-
| `Float f -> int_of_float f
25
-
| `String s -> (try int_of_string s with _ -> failwith "Invalid integer string")
26
-
| json -> failwith (Printf.sprintf "Expected int or float, got %s" (match json with
27
-
| `Null -> "null"
28
-
| `Bool _ -> "bool"
29
-
| `O _ -> "object"
30
-
| `A _ -> "array"
31
-
| _ -> "unknown"))
32
-
33
-
let get_int fields key =
34
-
match List.assoc_opt key fields with
35
-
| Some json ->
36
-
(try Ok (to_int_flex json) with
37
-
| Failure msg -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg ()))
38
-
| None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())
39
-
40
-
let get_int_default fields key default =
41
-
match get_int fields key with
42
-
| Ok i -> i
43
-
| Error _ -> default
44
-
45
-
let get_int_opt fields key =
46
-
match List.assoc_opt key fields with
47
-
| Some json -> (try Some (to_int_flex json) with _ -> None)
48
-
| None -> None
49
-
50
-
let get_float fields key =
51
-
match List.assoc_opt key fields with
52
-
| Some (`Float f) -> Ok f
53
-
| Some (`String s) ->
54
-
(try Ok (float_of_string s) with
55
-
| _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a valid float" key) ()))
56
-
| Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a float" key) ())
57
-
| None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())
58
-
59
-
let get_float_default fields key default =
60
-
match get_float fields key with
61
-
| Ok f -> f
62
-
| Error _ -> default
63
-
64
-
let get_bool fields key =
65
-
match List.assoc_opt key fields with
66
-
| Some (`Bool b) -> Ok b
67
-
| Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not a boolean" key) ())
68
-
| None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())
69
-
70
-
let get_bool_default fields key default =
71
-
match get_bool fields key with
72
-
| Ok b -> b
73
-
| Error _ -> default
74
-
75
-
let get_bool_opt fields key =
76
-
match List.assoc_opt key fields with
77
-
| Some (`Bool b) -> Some b
78
-
| _ -> None
79
-
80
-
let get_object fields key =
81
-
match List.assoc_opt key fields with
82
-
| Some (`O obj) -> Ok obj
83
-
| Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not an object" key) ())
84
-
| None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())
85
-
86
-
let get_object_opt fields key =
87
-
match List.assoc_opt key fields with
88
-
| Some (`O obj) -> Some obj
89
-
| _ -> None
90
-
91
-
let get_array fields key =
92
-
match List.assoc_opt key fields with
93
-
| Some (`A arr) -> Ok arr
94
-
| Some _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' is not an array" key) ())
95
-
| None -> Error (Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Field '%s' not found" key) ())
96
-
97
-
let get_array_opt fields key =
98
-
match List.assoc_opt key fields with
99
-
| Some (`A arr) -> Some arr
100
-
| _ -> None
101
-
102
-
(** {1 Type conversion utilities} *)
103
-
104
-
let to_int_safe = function
105
-
| `Float f -> Some (int_of_float f)
106
-
| `String s -> (try Some (int_of_string s) with _ -> None)
107
-
| _ -> None
108
-
109
-
let to_string_safe = function
110
-
| `String s -> Some s
111
-
| _ -> None
112
-
113
-
let to_bool_safe = function
114
-
| `Bool b -> Some b
115
-
| _ -> None
116
-
117
-
let to_float_safe = function
118
-
| `Float f -> Some f
119
-
| `String s -> (try Some (float_of_string s) with _ -> None)
120
-
| _ -> None
121
-
122
-
(** {1 Object parsing utilities} *)
123
-
124
-
let with_object context f = function
125
-
| `O fields -> f fields
126
-
| _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "%s: expected JSON object" context) ())
127
-
128
-
let with_array context f json =
129
-
match json with
130
-
| `A items ->
131
-
let rec process acc = function
132
-
| [] -> Ok (List.rev acc)
133
-
| item :: rest ->
134
-
match f item with
135
-
| Ok v -> process (v :: acc) rest
136
-
| Error e -> Error e
137
-
in
138
-
process [] items
139
-
| _ -> Error (Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "%s: expected JSON array" context) ())
140
-
141
-
(** {1 Construction utilities} *)
142
-
143
-
let optional_field key encoder = function
144
-
| Some value -> Some (key, encoder value)
145
-
| None -> None
146
-
147
-
let optional_fields fields =
148
-
List.filter_map (fun x -> x) fields
149
-
150
-
let string_array strings =
151
-
`A (List.map (fun s -> `String s) strings)
152
-
153
-
let int_array ints =
154
-
`A (List.map (fun i -> `Float (float_of_int i)) ints)
155
-
156
-
(** {1 Error handling} *)
157
-
158
-
let json_error msg =
159
-
Zulip_types.create_error ~code:(Other "json_error") ~msg ()
160
-
161
-
let field_missing_error field =
162
-
Zulip_types.create_error ~code:(Other "json_missing_field") ~msg:(Printf.sprintf "Required field '%s' not found" field) ()
163
-
164
-
let type_mismatch_error field expected =
165
-
Zulip_types.create_error ~code:(Other "json_type_error") ~msg:(Printf.sprintf "Field '%s' type mismatch: expected %s" field expected) ()
166
-
167
-
let parse_with_error context f =
168
-
try f ()
169
-
with
170
-
| Failure msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:(Printf.sprintf "%s: %s" context msg) ())
171
-
| exn -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg:(Printf.sprintf "%s: %s" context (Printexc.to_string exn)) ())
172
-
173
-
174
-
(** {1 Debugging utilities} *)
175
-
176
-
let to_string_pretty json =
177
-
let rec aux indent = function
178
-
| `Null -> "null"
179
-
| `Bool b -> string_of_bool b
180
-
| `Float f ->
181
-
if float_of_int (int_of_float f) = f then
182
-
string_of_int (int_of_float f)
183
-
else
184
-
string_of_float f
185
-
| `String s -> Printf.sprintf "%S" s
186
-
| `A [] -> "[]"
187
-
| `A lst ->
188
-
let items = List.map (aux (indent ^ " ")) lst in
189
-
Printf.sprintf "[\n%s%s\n%s]"
190
-
(indent ^ " ")
191
-
(String.concat (",\n" ^ indent ^ " ") items)
192
-
indent
193
-
| `O [] -> "{}"
194
-
| `O fields ->
195
-
let items = List.map (fun (k, v) ->
196
-
Printf.sprintf "%S: %s" k (aux (indent ^ " ") v)
197
-
) fields in
198
-
Printf.sprintf "{\n%s%s\n%s}"
199
-
(indent ^ " ")
200
-
(String.concat (",\n" ^ indent ^ " ") items)
201
-
indent
202
-
in
203
-
aux "" json
204
-
205
-
let pp fmt json =
206
-
Format.pp_print_string fmt (to_string_pretty json)
-117
stack/zulip/lib/zulip/lib/jsonu.mli
-117
stack/zulip/lib/zulip/lib/jsonu.mli
···
1
-
(** JSON utility functions for Zulip API
2
-
3
-
This module provides common utilities for working with JSON in the Zulip API,
4
-
reducing boilerplate and providing consistent error handling. *)
5
-
6
-
(** {1 Type definitions} *)
7
-
8
-
type json = Zulip_types.json
9
-
10
-
(** {1 Field extraction utilities} *)
11
-
12
-
(** Extract a string field from a JSON object *)
13
-
val get_string : (string * json) list -> string -> (string, Zulip_types.zerror) result
14
-
15
-
(** Extract a string field with a default value *)
16
-
val get_string_default : (string * json) list -> string -> string -> string
17
-
18
-
(** Extract an optional string field *)
19
-
val get_string_opt : (string * json) list -> string -> string option
20
-
21
-
(** Extract an integer field (handles both int and float representations) *)
22
-
val get_int : (string * json) list -> string -> (int, Zulip_types.zerror) result
23
-
24
-
(** Extract an integer field with a default value *)
25
-
val get_int_default : (string * json) list -> string -> int -> int
26
-
27
-
(** Extract an optional integer field *)
28
-
val get_int_opt : (string * json) list -> string -> int option
29
-
30
-
(** Extract a float field *)
31
-
val get_float : (string * json) list -> string -> (float, Zulip_types.zerror) result
32
-
33
-
(** Extract a float field with a default value *)
34
-
val get_float_default : (string * json) list -> string -> float -> float
35
-
36
-
(** Extract a boolean field *)
37
-
val get_bool : (string * json) list -> string -> (bool, Zulip_types.zerror) result
38
-
39
-
(** Extract a boolean field with a default value *)
40
-
val get_bool_default : (string * json) list -> string -> bool -> bool
41
-
42
-
(** Extract an optional boolean field *)
43
-
val get_bool_opt : (string * json) list -> string -> bool option
44
-
45
-
(** Extract a JSON object field *)
46
-
val get_object : (string * json) list -> string -> ((string * json) list, Zulip_types.zerror) result
47
-
48
-
(** Extract an optional JSON object field *)
49
-
val get_object_opt : (string * json) list -> string -> (string * json) list option
50
-
51
-
(** Extract a JSON array field *)
52
-
val get_array : (string * json) list -> string -> (json list, Zulip_types.zerror) result
53
-
54
-
(** Extract an optional JSON array field *)
55
-
val get_array_opt : (string * json) list -> string -> json list option
56
-
57
-
(** {1 Type conversion utilities} *)
58
-
59
-
(** Convert JSON to int, handling both int and float representations *)
60
-
val to_int_flex : json -> int
61
-
62
-
(** Safely convert JSON to int *)
63
-
val to_int_safe : json -> int option
64
-
65
-
(** Convert JSON to string *)
66
-
val to_string_safe : json -> string option
67
-
68
-
(** Convert JSON to bool *)
69
-
val to_bool_safe : json -> bool option
70
-
71
-
(** Convert JSON to float *)
72
-
val to_float_safe : json -> float option
73
-
74
-
(** {1 Object parsing utilities} *)
75
-
76
-
(** Parse a JSON value as an object, applying a function to its fields *)
77
-
val with_object : string -> ((string * json) list -> ('a, Zulip_types.zerror) result) -> json -> ('a, Zulip_types.zerror) result
78
-
79
-
(** Parse a JSON value as an array, applying a function to each element *)
80
-
val with_array : string -> (json -> ('a, Zulip_types.zerror) result) -> json -> ('a list, Zulip_types.zerror) result
81
-
82
-
(** {1 Construction utilities} *)
83
-
84
-
(** Create an optional field for JSON object construction *)
85
-
val optional_field : string -> ('a -> json) -> 'a option -> (string * json) option
86
-
87
-
(** Create a list of optional fields, filtering out None values *)
88
-
val optional_fields : (string * json) option list -> (string * json) list
89
-
90
-
(** Convert a string list to a JSON array *)
91
-
val string_array : string list -> json
92
-
93
-
(** Convert an int list to a JSON array *)
94
-
val int_array : int list -> json
95
-
96
-
(** {1 Error handling} *)
97
-
98
-
(** Create a JSON parsing error *)
99
-
val json_error : string -> Zulip_types.zerror
100
-
101
-
(** Create a field missing error *)
102
-
val field_missing_error : string -> Zulip_types.zerror
103
-
104
-
(** Create a type mismatch error *)
105
-
val type_mismatch_error : string -> string -> Zulip_types.zerror
106
-
107
-
(** Wrap a parsing function with exception handling *)
108
-
val parse_with_error : string -> (unit -> ('a, Zulip_types.zerror) result) -> ('a, Zulip_types.zerror) result
109
-
110
-
111
-
(** {1 Debugging utilities} *)
112
-
113
-
(** Convert JSON to a pretty-printed string *)
114
-
val to_string_pretty : json -> string
115
-
116
-
(** Print JSON value for debugging *)
117
-
val pp : Format.formatter -> json -> unit
-144
stack/zulip/lib/zulip/lib/jsonu_syntax.ml
-144
stack/zulip/lib/zulip/lib/jsonu_syntax.ml
···
1
-
(** Syntax module for monadic and applicative JSON parsing *)
2
-
3
-
type json = Zulip_types.json
4
-
type 'a parser = json -> ('a, Zulip_types.zerror) result
5
-
6
-
(** Monadic bind operator for sequential parsing with error handling *)
7
-
let ( let* ) = Result.bind
8
-
9
-
(** Map operator for transforming successful results *)
10
-
let ( let+ ) x f = Result.map f x
11
-
12
-
(** Applicative parallel composition *)
13
-
let ( and+ ) x y =
14
-
match x, y with
15
-
| Ok x, Ok y -> Ok (x, y)
16
-
| Error e, _ | _, Error e -> Error e
17
-
18
-
(** Applicative parallel composition for 3 values *)
19
-
let ( and++ ) xy z =
20
-
match xy, z with
21
-
| Ok (x, y), Ok z -> Ok (x, y, z)
22
-
| Error e, _ | _, Error e -> Error e
23
-
24
-
(** Applicative parallel composition for 4 values *)
25
-
let ( and+++ ) xyz w =
26
-
match xyz, w with
27
-
| Ok (x, y, z), Ok w -> Ok (x, y, z, w)
28
-
| Error e, _ | _, Error e -> Error e
29
-
30
-
(** Applicative parallel composition for 5 values *)
31
-
let ( and++++ ) xyzw v =
32
-
match xyzw, v with
33
-
| Ok (x, y, z, w), Ok v -> Ok (x, y, z, w, v)
34
-
| Error e, _ | _, Error e -> Error e
35
-
36
-
(** Alternative operator - try first, if fails try second *)
37
-
let ( <|> ) x y =
38
-
match x with
39
-
| Ok _ -> x
40
-
| Error _ -> y
41
-
42
-
(** Provide a default value if parsing fails *)
43
-
let ( |? ) x default =
44
-
match x with
45
-
| Ok v -> v
46
-
| Error _ -> default
47
-
48
-
(** Convert option to result with error message *)
49
-
let required name = function
50
-
| Some v -> Ok v
51
-
| None -> Error (Zulip_types.create_error ~code:(Other "missing_field") ~msg:(Printf.sprintf "Required field '%s' not found" name) ())
52
-
53
-
(** Convert option to result with default *)
54
-
let default v = function
55
-
| Some x -> x
56
-
| None -> v
57
-
58
-
(** Lift a pure value into parser context *)
59
-
let pure x = Ok x
60
-
61
-
(** Fail with an error message *)
62
-
let fail msg = Error (Zulip_types.create_error ~code:(Other "parse_error") ~msg ())
63
-
64
-
(** Map over a list with error handling *)
65
-
let traverse f lst =
66
-
let rec go acc = function
67
-
| [] -> Ok (List.rev acc)
68
-
| x :: xs ->
69
-
let* v = f x in
70
-
go (v :: acc) xs
71
-
in
72
-
go [] lst
73
-
74
-
(** Filter and map over a list, dropping errors *)
75
-
let filter_map f lst =
76
-
List.filter_map (fun x ->
77
-
match f x with
78
-
| Ok v -> Some v
79
-
| Error _ -> None
80
-
) lst
81
-
82
-
(** Parse a field with a custom parser *)
83
-
let field fields key parser =
84
-
match List.assoc_opt key fields with
85
-
| Some json -> parser json
86
-
| None -> Error (Jsonu.field_missing_error key)
87
-
88
-
(** Parse an optional field with a custom parser *)
89
-
let field_opt fields key parser =
90
-
match List.assoc_opt key fields with
91
-
| Some json ->
92
-
(match parser json with
93
-
| Ok v -> Ok (Some v)
94
-
| Error _ -> Ok None)
95
-
| None -> Ok None
96
-
97
-
(** Parse a field with a default value if missing or fails *)
98
-
let field_or fields key parser default =
99
-
match List.assoc_opt key fields with
100
-
| Some json ->
101
-
(match parser json with
102
-
| Ok v -> Ok v
103
-
| Error _ -> Ok default)
104
-
| None -> Ok default
105
-
106
-
(** Common parsers *)
107
-
let string = function
108
-
| `String s -> Ok s
109
-
| _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected string" ())
110
-
111
-
let int = function
112
-
| `Float f -> Ok (int_of_float f)
113
-
| `String s ->
114
-
(try Ok (int_of_string s)
115
-
with _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected integer" ()))
116
-
| _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected integer" ())
117
-
118
-
let float = function
119
-
| `Float f -> Ok f
120
-
| `String s ->
121
-
(try Ok (float_of_string s)
122
-
with _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected float" ()))
123
-
| _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected float" ())
124
-
125
-
let bool = function
126
-
| `Bool b -> Ok b
127
-
| _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected boolean" ())
128
-
129
-
let array parser = function
130
-
| `A items -> traverse parser items
131
-
| _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected array" ())
132
-
133
-
let object_ = function
134
-
| `O fields -> Ok fields
135
-
| _ -> Error (Zulip_types.create_error ~code:(Other "type_error") ~msg:"Expected object" ())
136
-
137
-
(** Run a parser on JSON *)
138
-
let parse parser json = parser json
139
-
140
-
(** Run a parser with error context *)
141
-
let with_context ctx parser json =
142
-
match parser json with
143
-
| Ok v -> Ok v
144
-
| Error e -> Error (Zulip_types.create_error ~code:(Zulip_types.error_code e) ~msg:(Printf.sprintf "%s: %s" ctx (Zulip_types.error_message e)) ())
-96
stack/zulip/lib/zulip/lib/jsonu_syntax.mli
-96
stack/zulip/lib/zulip/lib/jsonu_syntax.mli
···
1
-
(** Syntax module for monadic and applicative JSON parsing
2
-
3
-
This module provides binding operators and combinators to make JSON parsing
4
-
more ergonomic and composable. It enables code like:
5
-
6
-
{[
7
-
let parse_user json =
8
-
with_object "user" @@ fun fields ->
9
-
let+ user_id = field fields "user_id" int
10
-
and+ email = field fields "email" string
11
-
and+ full_name = field fields "full_name" string in
12
-
{ user_id; email; full_name }
13
-
]}
14
-
*)
15
-
16
-
type json = Zulip_types.json
17
-
type 'a parser = json -> ('a, Zulip_types.zerror) result
18
-
19
-
(** {1 Binding Operators} *)
20
-
21
-
(** Monadic bind operator for sequential parsing with error handling *)
22
-
val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result
23
-
24
-
(** Map operator for transforming successful results *)
25
-
val ( let+ ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result
26
-
27
-
(** Applicative parallel composition for independent field extraction *)
28
-
val ( and+ ) : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e) result
29
-
val ( and++ ) : ('a * 'b, 'e) result -> ('c, 'e) result -> ('a * 'b * 'c, 'e) result
30
-
val ( and+++ ) : ('a * 'b * 'c, 'e) result -> ('d, 'e) result -> ('a * 'b * 'c * 'd, 'e) result
31
-
val ( and++++ ) : ('a * 'b * 'c * 'd, 'e) result -> ('f, 'e) result -> ('a * 'b * 'c * 'd * 'f, 'e) result
32
-
33
-
(** {1 Alternative and Default Operators} *)
34
-
35
-
(** Alternative operator - try first parser, if fails try second *)
36
-
val ( <|> ) : ('a, 'e) result -> ('a, 'e) result -> ('a, 'e) result
37
-
38
-
(** Provide a default value if parsing fails *)
39
-
val ( |? ) : ('a, 'e) result -> 'a -> 'a
40
-
41
-
(** {1 Field Extraction} *)
42
-
43
-
(** Parse a required field with a custom parser *)
44
-
val field : (string * json) list -> string -> 'a parser -> ('a, Zulip_types.zerror) result
45
-
46
-
(** Parse an optional field with a custom parser *)
47
-
val field_opt : (string * json) list -> string -> 'a parser -> ('a option, Zulip_types.zerror) result
48
-
49
-
(** Parse a field with a default value if missing or fails *)
50
-
val field_or : (string * json) list -> string -> 'a parser -> 'a -> ('a, Zulip_types.zerror) result
51
-
52
-
(** {1 Basic Parsers} *)
53
-
54
-
(** Parse a JSON string *)
55
-
val string : string parser
56
-
57
-
(** Parse a JSON number as integer (handles both int and float) *)
58
-
val int : int parser
59
-
60
-
(** Parse a JSON number as float *)
61
-
val float : float parser
62
-
63
-
(** Parse a JSON boolean *)
64
-
val bool : bool parser
65
-
66
-
(** Parse a JSON array with a parser for elements *)
67
-
val array : 'a parser -> 'a list parser
68
-
69
-
(** Parse a JSON object to get its fields *)
70
-
val object_ : json -> ((string * json) list, Zulip_types.zerror) result
71
-
72
-
(** {1 Utility Functions} *)
73
-
74
-
(** Convert option to result with error message *)
75
-
val required : string -> 'a option -> ('a, Zulip_types.zerror) result
76
-
77
-
(** Get value from option with default *)
78
-
val default : 'a -> 'a option -> 'a
79
-
80
-
(** Lift a pure value into parser context *)
81
-
val pure : 'a -> ('a, 'e) result
82
-
83
-
(** Fail with an error message *)
84
-
val fail : string -> ('a, Zulip_types.zerror) result
85
-
86
-
(** Map over a list with error handling *)
87
-
val traverse : ('a -> ('b, Zulip_types.zerror) result) -> 'a list -> ('b list, Zulip_types.zerror) result
88
-
89
-
(** Filter and map over a list, dropping errors *)
90
-
val filter_map : ('a -> ('b, Zulip_types.zerror) result) -> 'a list -> 'b list
91
-
92
-
(** Run a parser on JSON *)
93
-
val parse : 'a parser -> json -> ('a, Zulip_types.zerror) result
94
-
95
-
(** Run a parser with error context *)
96
-
val with_context : string -> 'a parser -> 'a parser
+35
-21
stack/zulip/lib/zulip/lib/message.ml
+35
-21
stack/zulip/lib/zulip/lib/message.ml
···
19
19
let local_id t = t.local_id
20
20
let read_by_sender t = t.read_by_sender
21
21
22
-
let to_json t =
23
-
let base_fields = [
24
-
("type", `String (Message_type.to_string t.type_));
25
-
("to", `A (List.map (fun s -> `String s) t.to_));
26
-
("content", `String t.content);
27
-
("read_by_sender", `Bool t.read_by_sender);
28
-
] in
29
-
let with_topic = match t.topic with
30
-
| Some topic -> ("topic", `String topic) :: base_fields
31
-
| None -> base_fields in
32
-
let with_queue_id = match t.queue_id with
33
-
| Some qid -> ("queue_id", `String qid) :: with_topic
34
-
| None -> with_topic in
35
-
let with_local_id = match t.local_id with
36
-
| Some lid -> ("local_id", `String lid) :: with_queue_id
37
-
| None -> with_queue_id in
38
-
`O with_local_id
22
+
let pp fmt t = Format.fprintf fmt "Message{type=%a, to=%s, content=%s}"
23
+
Message_type.pp t.type_
24
+
(String.concat "," t.to_)
25
+
t.content
39
26
40
-
let pp fmt t = Format.fprintf fmt "Message{type=%a, to=%s, content=%s}"
41
-
Message_type.pp t.type_
42
-
(String.concat "," t.to_)
43
-
t.content
27
+
(* Jsont codec for Message_type.t *)
28
+
let message_type_jsont =
29
+
let of_string s = match Message_type.of_string s with
30
+
| Some t -> Ok t
31
+
| None -> Error (Format.sprintf "Invalid message type: %s" s)
32
+
in
33
+
Jsont.of_of_string ~kind:"Message_type.t" of_string ~enc:Message_type.to_string
34
+
35
+
(* Jsont codec for the message *)
36
+
let jsont =
37
+
let kind = "Message" in
38
+
let doc = "A Zulip message to be sent" in
39
+
let make type_ to_ content topic queue_id local_id read_by_sender =
40
+
{ type_; to_; content; topic; queue_id; local_id; read_by_sender }
41
+
in
42
+
Jsont.Object.map ~kind ~doc make
43
+
|> Jsont.Object.mem "type" message_type_jsont ~enc:type_
44
+
|> Jsont.Object.mem "to" (Jsont.list Jsont.string) ~enc:to_
45
+
|> Jsont.Object.mem "content" Jsont.string ~enc:content
46
+
|> Jsont.Object.opt_mem "topic" Jsont.string ~enc:topic
47
+
|> Jsont.Object.opt_mem "queue_id" Jsont.string ~enc:queue_id
48
+
|> Jsont.Object.opt_mem "local_id" Jsont.string ~enc:local_id
49
+
|> Jsont.Object.mem "read_by_sender" Jsont.bool ~enc:read_by_sender
50
+
|> Jsont.Object.finish
51
+
52
+
(* Encoding functions *)
53
+
let to_json_string t =
54
+
Encode.to_json_string jsont t
55
+
56
+
let to_form_urlencoded t =
57
+
Encode.to_form_urlencoded jsont t
+18
-9
stack/zulip/lib/zulip/lib/message.mli
+18
-9
stack/zulip/lib/zulip/lib/message.mli
···
1
1
type t
2
2
3
-
val create :
4
-
type_:Message_type.t ->
5
-
to_:string list ->
6
-
content:string ->
7
-
?topic:string ->
8
-
?queue_id:string ->
9
-
?local_id:string ->
10
-
?read_by_sender:bool ->
3
+
val create :
4
+
type_:Message_type.t ->
5
+
to_:string list ->
6
+
content:string ->
7
+
?topic:string ->
8
+
?queue_id:string ->
9
+
?local_id:string ->
10
+
?read_by_sender:bool ->
11
11
unit -> t
12
12
13
13
val type_ : t -> Message_type.t
···
17
17
val queue_id : t -> string option
18
18
val local_id : t -> string option
19
19
val read_by_sender : t -> bool
20
-
val to_json : t -> Zulip_types.json
20
+
21
+
(** Jsont codec for the message type *)
22
+
val jsont : t Jsont.t
23
+
24
+
(** Encode to JSON string *)
25
+
val to_json_string : t -> string
26
+
27
+
(** Encode to form-urlencoded string *)
28
+
val to_form_urlencoded : t -> string
29
+
21
30
val pp : Format.formatter -> t -> unit
+20
-8
stack/zulip/lib/zulip/lib/message_response.ml
+20
-8
stack/zulip/lib/zulip/lib/message_response.ml
···
6
6
let id t = t.id
7
7
let automatic_new_visibility_policy t = t.automatic_new_visibility_policy
8
8
9
+
let pp fmt t = Format.fprintf fmt "MessageResponse{id=%d}" t.id
10
+
11
+
(* Jsont codec for message response *)
12
+
let jsont =
13
+
let kind = "MessageResponse" in
14
+
let doc = "A Zulip message response" in
15
+
let make id automatic_new_visibility_policy =
16
+
{ id; automatic_new_visibility_policy }
17
+
in
18
+
Jsont.Object.map ~kind ~doc make
19
+
|> Jsont.Object.mem "id" Jsont.int ~enc:id
20
+
|> Jsont.Object.opt_mem "automatic_new_visibility_policy" Jsont.string ~enc:automatic_new_visibility_policy
21
+
|> Jsont.Object.finish
22
+
23
+
(* Decode and encode functions using Encode module *)
9
24
let of_json json =
10
-
Jsonu.with_object "message_response" (fun fields ->
11
-
match Jsonu.get_int fields "id" with
12
-
| Error e -> Error e
13
-
| Ok id ->
14
-
let automatic_new_visibility_policy = Jsonu.get_string_opt fields "automatic_new_visibility_policy" in
15
-
Ok { id; automatic_new_visibility_policy }
16
-
) json
25
+
match Encode.from_json jsont json with
26
+
| Ok v -> Ok v
27
+
| Error msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg ())
17
28
18
-
let pp fmt t = Format.fprintf fmt "MessageResponse{id=%d}" t.id
29
+
let to_json_string t =
30
+
Encode.to_json_string jsont t
+5
stack/zulip/lib/zulip/lib/message_response.mli
+5
stack/zulip/lib/zulip/lib/message_response.mli
···
2
2
3
3
val id : t -> int
4
4
val automatic_new_visibility_policy : t -> string option
5
+
6
+
(** Jsont codec for message response *)
7
+
val jsont : t Jsont.t
8
+
5
9
val of_json : Zulip_types.json -> (t, Zulip_types.zerror) result
10
+
val to_json_string : t -> string
6
11
val pp : Format.formatter -> t -> unit
+15
-62
stack/zulip/lib/zulip/lib/messages.ml
+15
-62
stack/zulip/lib/zulip/lib/messages.ml
···
1
1
let send client message =
2
-
let json = Message.to_json message in
3
-
let params = match json with
4
-
| `O fields ->
5
-
List.fold_left (fun acc (key, value) ->
6
-
let str_value = match value with
7
-
| `String s -> s
8
-
| `Bool true -> "true"
9
-
| `Bool false -> "false"
10
-
| `A arr -> String.concat "," (List.map (function `String s -> s | _ -> "") arr)
11
-
| _ -> ""
12
-
in
13
-
(key, str_value) :: acc
14
-
) [] fields
15
-
| _ -> [] in
16
-
17
-
match Client.request client ~method_:`POST ~path:"/api/v1/messages" ~params () with
2
+
(* Use form-urlencoded encoding for the message *)
3
+
let body = Message.to_form_urlencoded message in
4
+
let content_type = "application/x-www-form-urlencoded" in
5
+
6
+
match Client.request client ~method_:`POST ~path:"/api/v1/messages" ~body ~content_type () with
18
7
| Ok response -> Message_response.of_json response
19
8
| Error err -> Error err
20
9
21
10
let edit client ~message_id ?content ?topic () =
22
-
let params =
11
+
let params =
23
12
(("message_id", string_of_int message_id) ::
24
13
(match content with Some c -> [("content", c)] | None -> []) @
25
14
(match topic with Some t -> [("topic", t)] | None -> [])) in
26
-
15
+
27
16
match Client.request client ~method_:`PATCH ~path:("/api/v1/messages/" ^ string_of_int message_id) ~params () with
28
17
| Ok _ -> Ok ()
29
18
| Error err -> Error err
···
48
37
let add_reaction client ~message_id ~emoji_name =
49
38
let params = [
50
39
("emoji_name", emoji_name);
51
-
("reaction_type", "unicode_emoji");
52
40
] in
53
41
match Client.request client ~method_:`POST
54
-
~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions")
55
-
~params () with
56
-
| Ok _ -> Ok ()
42
+
~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions") ~params () with
43
+
| Ok _json -> Ok ()
57
44
| Error err -> Error err
58
45
59
46
let remove_reaction client ~message_id ~emoji_name =
60
47
let params = [
61
48
("emoji_name", emoji_name);
62
-
("reaction_type", "unicode_emoji");
63
49
] in
64
50
match Client.request client ~method_:`DELETE
65
-
~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions")
66
-
~params () with
67
-
| Ok _ -> Ok ()
51
+
~path:("/api/v1/messages/" ^ string_of_int message_id ^ "/reactions") ~params () with
52
+
| Ok _json -> Ok ()
68
53
| Error err -> Error err
69
54
70
-
let upload_file client ~filename =
71
-
(* Read file contents *)
72
-
let ic = open_in_bin filename in
73
-
let len = in_channel_length ic in
74
-
let content = really_input_string ic len in
75
-
close_in ic;
76
-
77
-
(* Extract just the filename from the path *)
78
-
let basename = Filename.basename filename in
79
-
80
-
(* Create multipart form data boundary *)
81
-
let boundary = "----OCamlZulipBoundary" ^ string_of_float (Unix.gettimeofday ()) in
82
-
83
-
(* Build multipart body *)
84
-
let body = Buffer.create (len + 1024) in
85
-
Buffer.add_string body ("--" ^ boundary ^ "\r\n");
86
-
Buffer.add_string body ("Content-Disposition: form-data; name=\"file\"; filename=\"" ^ basename ^ "\"\r\n");
87
-
Buffer.add_string body "Content-Type: application/octet-stream\r\n";
88
-
Buffer.add_string body "\r\n";
89
-
Buffer.add_string body content;
90
-
Buffer.add_string body ("\r\n--" ^ boundary ^ "--\r\n");
91
-
92
-
let body_str = Buffer.contents body in
93
-
let content_type = "multipart/form-data; boundary=" ^ boundary in
94
-
95
-
match Client.request client ~method_:`POST ~path:"/api/v1/user_uploads"
96
-
~body:body_str ~content_type () with
97
-
| Ok json ->
98
-
(* Parse response to extract URI *)
99
-
(match json with
100
-
| `O fields ->
101
-
(match Jsonu.get_string fields "uri" with
102
-
| Ok uri -> Ok uri
103
-
| Error e -> Error e)
104
-
| _ -> Error (Zulip_types.create_error ~code:(Zulip_types.Other "upload_error") ~msg:"Failed to parse upload response" ()))
105
-
| Error err -> Error err
55
+
let upload_file _client ~filename:_ =
56
+
(* TODO: Implement file upload using multipart/form-data *)
57
+
Error (Zulip_types.create_error ~code:(Other "not_implemented")
58
+
~msg:"File upload not yet implemented" ())
+25
-18
stack/zulip/lib/zulip/lib/user.ml
+25
-18
stack/zulip/lib/zulip/lib/user.ml
···
15
15
let is_admin t = t.is_admin
16
16
let is_bot t = t.is_bot
17
17
18
-
let to_json t =
19
-
`O [
20
-
("email", `String t.email);
21
-
("full_name", `String t.full_name);
22
-
("is_active", `Bool t.is_active);
23
-
("is_admin", `Bool t.is_admin);
24
-
("is_bot", `Bool t.is_bot);
25
-
]
18
+
let pp fmt t = Format.fprintf fmt "User{email=%s, full_name=%s}" t.email t.full_name
19
+
20
+
(* Jsont codec for user *)
21
+
let jsont =
22
+
let kind = "User" in
23
+
let doc = "A Zulip user" in
24
+
let make email full_name is_active is_admin is_bot =
25
+
{ email; full_name; is_active; is_admin; is_bot }
26
+
in
27
+
Jsont.Object.map ~kind ~doc make
28
+
|> Jsont.Object.mem "email" Jsont.string ~enc:email
29
+
|> Jsont.Object.mem "full_name" Jsont.string ~enc:full_name
30
+
|> Jsont.Object.mem "is_active" Jsont.bool ~enc:is_active
31
+
|> Jsont.Object.mem "is_admin" Jsont.bool ~enc:is_admin
32
+
|> Jsont.Object.mem "is_bot" Jsont.bool ~enc:is_bot
33
+
|> Jsont.Object.finish
26
34
35
+
(* Decode and encode functions using Encode module *)
27
36
let of_json json =
28
-
Jsonu.with_object "user" (fun fields ->
29
-
match Jsonu.get_string fields "email", Jsonu.get_string fields "full_name" with
30
-
| Ok email, Ok full_name ->
31
-
let is_active = Jsonu.get_bool_default fields "is_active" true in
32
-
let is_admin = Jsonu.get_bool_default fields "is_admin" false in
33
-
let is_bot = Jsonu.get_bool_default fields "is_bot" false in
34
-
Ok { email; full_name; is_active; is_admin; is_bot }
35
-
| Error e, _ | _, Error e -> Error e
36
-
) json
37
+
match Encode.from_json jsont json with
38
+
| Ok v -> Ok v
39
+
| Error msg -> Error (Zulip_types.create_error ~code:(Other "json_parse_error") ~msg ())
40
+
41
+
let to_json_string t =
42
+
Encode.to_json_string jsont t
37
43
38
-
let pp fmt t = Format.fprintf fmt "User{email=%s, full_name=%s}" t.email t.full_name
44
+
let to_form_urlencoded t =
45
+
Encode.to_form_urlencoded jsont t
+18
-7
stack/zulip/lib/zulip/lib/user.mli
+18
-7
stack/zulip/lib/zulip/lib/user.mli
···
1
1
type t
2
2
3
-
val create :
4
-
email:string ->
5
-
full_name:string ->
6
-
?is_active:bool ->
7
-
?is_admin:bool ->
8
-
?is_bot:bool ->
3
+
val create :
4
+
email:string ->
5
+
full_name:string ->
6
+
?is_active:bool ->
7
+
?is_admin:bool ->
8
+
?is_bot:bool ->
9
9
unit -> t
10
10
11
11
val email : t -> string
···
13
13
val is_active : t -> bool
14
14
val is_admin : t -> bool
15
15
val is_bot : t -> bool
16
-
val to_json : t -> Zulip_types.json
16
+
17
+
(** Jsont codec for the user type *)
18
+
val jsont : t Jsont.t
19
+
20
+
(** Decode from Jsont.json *)
17
21
val of_json : Zulip_types.json -> (t, Zulip_types.zerror) result
22
+
23
+
(** Encode to JSON string *)
24
+
val to_json_string : t -> string
25
+
26
+
(** Encode to form-urlencoded string *)
27
+
val to_form_urlencoded : t -> string
28
+
18
29
val pp : Format.formatter -> t -> unit
+32
-28
stack/zulip/lib/zulip/lib/users.ml
+32
-28
stack/zulip/lib/zulip/lib/users.ml
···
1
-
let list client =
1
+
let list client =
2
+
(* Define response codec *)
3
+
let response_codec =
4
+
Jsont.Object.(
5
+
map ~kind:"UsersResponse" (fun members -> members)
6
+
|> mem "members" (Jsont.list User.jsont) ~enc:(fun x -> x)
7
+
|> finish
8
+
)
9
+
in
10
+
2
11
match Client.request client ~method_:`GET ~path:"/api/v1/users" () with
3
-
| Ok json ->
4
-
(match json with
5
-
| `O fields ->
6
-
(match List.assoc_opt "members" fields with
7
-
| Some (`A user_list) ->
8
-
let users = List.fold_left (fun acc user_json ->
9
-
match User.of_json user_json with
10
-
| Ok user -> user :: acc
11
-
| Error _ -> acc
12
-
) [] user_list in
13
-
Ok (List.rev users)
14
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Invalid users response format" ()))
15
-
| _ -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg:"Users response must be an object" ()))
12
+
| Ok json ->
13
+
(match Encode.from_json response_codec json with
14
+
| Ok users -> Ok users
15
+
| Error msg -> Error (Zulip_types.create_error ~code:(Other "api_error") ~msg ()))
16
16
| Error err -> Error err
17
17
18
18
let get client ~email =
···
23
23
| Error err -> Error err)
24
24
| Error err -> Error err
25
25
26
-
let create_user client ~email ~full_name =
27
-
let body_json = `O [
28
-
("email", `String email);
29
-
("full_name", `String full_name);
30
-
] in
31
-
let body = match body_json with
32
-
| `O fields ->
33
-
String.concat "&" (List.map (fun (k, v) ->
34
-
match v with
35
-
| `String s -> k ^ "=" ^ s
36
-
| _ -> ""
37
-
) fields)
38
-
| _ -> "" in
39
-
match Client.request client ~method_:`POST ~path:"/api/v1/users" ~body () with
26
+
(* Request type for create_user *)
27
+
module Create_user_request = struct
28
+
type t = { email : string; full_name : string }
29
+
30
+
let codec =
31
+
Jsont.Object.(
32
+
map ~kind:"CreateUserRequest" (fun email full_name -> { email; full_name })
33
+
|> mem "email" Jsont.string ~enc:(fun r -> r.email)
34
+
|> mem "full_name" Jsont.string ~enc:(fun r -> r.full_name)
35
+
|> finish
36
+
)
37
+
end
38
+
39
+
let create_user client ~email ~full_name =
40
+
let req = Create_user_request.{ email; full_name } in
41
+
let body = Encode.to_form_urlencoded Create_user_request.codec req in
42
+
let content_type = "application/x-www-form-urlencoded" in
43
+
match Client.request client ~method_:`POST ~path:"/api/v1/users" ~body ~content_type () with
40
44
| Ok _json -> Ok ()
41
45
| Error err -> Error err
42
46
+1
-5
stack/zulip/lib/zulip/lib/zulip.ml
+1
-5
stack/zulip/lib/zulip/lib/zulip.ml
+2
-10
stack/zulip/lib/zulip/lib/zulip.mli
+2
-10
stack/zulip/lib/zulip/lib/zulip.mli
···
65
65
module Event_type = Event_type
66
66
module Event_queue = Event_queue
67
67
68
-
(** {1 JSON Utilities} *)
69
-
70
-
(** JSON utility functions (abbreviated as J for convenience) *)
71
-
module J = Jsonu
72
-
73
-
(** JSON parsing syntax extensions *)
74
-
module Jsonu_syntax = Jsonu_syntax
75
-
76
-
(** Full JSON utilities module *)
77
-
module Jsonu = Jsonu
68
+
(** JSON encoding/decoding utilities *)
69
+
module Encode = Encode
78
70
+32
-15
stack/zulip/lib/zulip/lib/zulip_types.ml
+32
-15
stack/zulip/lib/zulip/lib/zulip_types.ml
···
1
1
(** Core types for Zulip API *)
2
2
3
3
(** JSON type used throughout the API *)
4
-
type json = [`Null | `Bool of bool | `Float of float | `String of string | `A of json list | `O of (string * json) list]
4
+
type json = Jsont.json
5
5
6
6
(** Error codes returned by Zulip API *)
7
7
type error_code =
···
45
45
let pp_error fmt t = Format.fprintf fmt "Error(%s): %s"
46
46
(error_code_to_string t.code) t.message
47
47
48
+
(* Jsont codec for error_code *)
49
+
let error_code_jsont =
50
+
let of_string s = Ok (error_code_of_string s) in
51
+
Jsont.of_of_string ~kind:"ErrorCode" of_string ~enc:error_code_to_string
52
+
53
+
(* Jsont codec for zerror *)
54
+
let zerror_jsont =
55
+
let kind = "ZulipError" in
56
+
let make code msg =
57
+
(* Extra fields handled by keep_unknown - we'll extract them separately *)
58
+
{ code = error_code_of_string code; message = msg; extra = [] }
59
+
in
60
+
let code t = error_code_to_string t.code in
61
+
let msg t = t.message in
62
+
Jsont.Object.(
63
+
map ~kind make
64
+
|> mem "code" Jsont.string ~enc:code
65
+
|> mem "msg" Jsont.string ~enc:msg
66
+
|> finish
67
+
)
68
+
48
69
let error_of_json json =
49
-
match json with
50
-
| `O fields ->
51
-
(try
52
-
let code_str = match List.assoc "code" fields with
53
-
| `String s -> s
54
-
| _ -> "OTHER" in
55
-
let msg = match List.assoc "msg" fields with
56
-
| `String s -> s
57
-
| _ -> "Unknown error" in
58
-
let code = error_code_of_string code_str in
59
-
let extra = List.filter (fun (k, _) -> k <> "code" && k <> "msg" && k <> "result") fields in
60
-
Some (create_error ~code ~msg ~extra ())
61
-
with Not_found -> None)
62
-
| _ -> None
70
+
match Encode.from_json zerror_jsont json with
71
+
| Ok err ->
72
+
(* Extract extra fields by getting all fields except code, msg, result *)
73
+
(match json with
74
+
| Jsont.Object (fields, _) ->
75
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
76
+
let extra = List.filter (fun (k, _) -> k <> "code" && k <> "msg" && k <> "result") assoc in
77
+
Some { err with extra }
78
+
| _ -> Some err)
79
+
| Error _ -> None
+6
-1
stack/zulip/lib/zulip/lib/zulip_types.mli
+6
-1
stack/zulip/lib/zulip/lib/zulip_types.mli
···
1
1
(** Core types for Zulip API *)
2
2
3
3
(** JSON type used throughout the API *)
4
-
type json = [`Null | `Bool of bool | `Float of float | `String of string | `A of json list | `O of (string * json) list]
4
+
type json = Jsont.json
5
5
6
6
(** Error codes returned by Zulip API *)
7
7
type error_code =
···
27
27
val error_message : zerror -> string
28
28
val error_extra : zerror -> (string * json) list
29
29
val pp_error : Format.formatter -> zerror -> unit
30
+
31
+
(** Jsont codecs *)
32
+
val error_code_jsont : error_code Jsont.t
33
+
val zerror_jsont : zerror Jsont.t
34
+
30
35
val error_of_json : json -> zerror option
+6
-5
stack/zulip/lib/zulip_bot/lib/bot_runner.ml
+6
-5
stack/zulip/lib/zulip_bot/lib/bot_runner.ml
···
45
45
(* Extract the actual message from the event *)
46
46
let message_json, flags =
47
47
match event_data with
48
-
| `O fields ->
49
-
let msg = match List.assoc_opt "message" fields with
48
+
| Jsont.Object (fields, _) ->
49
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
50
+
let msg = match List.assoc_opt "message" assoc with
50
51
| Some m -> m
51
52
| None -> event_data (* Fallback if structure is different *)
52
53
in
53
-
let flgs = match List.assoc_opt "flags" fields with
54
-
| Some (`A f) -> f
54
+
let flgs = match List.assoc_opt "flags" assoc with
55
+
| Some (Jsont.Array (f, _)) -> f
55
56
| _ -> []
56
57
in
57
58
(msg, flgs)
···
73
74
74
75
(* Check if mentioned *)
75
76
let is_mentioned =
76
-
List.exists (function `String "mentioned" -> true | _ -> false) flags ||
77
+
List.exists (function Jsont.String ("mentioned", _) -> true | _ -> false) flags ||
77
78
Message.is_mentioned message ~user_email:bot_email in
78
79
79
80
(* Check if it's a private message *)
+81
-29
stack/zulip/lib/zulip_bot/lib/bot_storage.ml
+81
-29
stack/zulip/lib/zulip_bot/lib/bot_storage.ml
···
9
9
mutable dirty_keys : string list;
10
10
}
11
11
12
+
(** {1 JSON Codecs for Bot Storage} *)
13
+
14
+
(* Storage response type - {"storage": {...}} *)
15
+
type storage_response = {
16
+
storage : (string * string) list;
17
+
unknown : Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
18
+
}
19
+
20
+
(* Custom codec for storage_response that handles the dictionary *)
21
+
let storage_response_jsont : storage_response Jsont.t =
22
+
let of_string s =
23
+
match Jsont_bytesrw.decode_string' Jsont.json s with
24
+
| Error _ -> Error "Failed to decode JSON"
25
+
| Ok json ->
26
+
match json with
27
+
| Jsont.Object (fields, _) ->
28
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
29
+
(match List.assoc_opt "storage" assoc with
30
+
| Some (Jsont.Object (storage_fields, _)) ->
31
+
let storage = List.filter_map (fun ((k, _), v) ->
32
+
match v with
33
+
| Jsont.String (s, _) -> Some (k, s)
34
+
| _ -> None
35
+
) storage_fields in
36
+
(* Keep unknown fields *)
37
+
let unknown_fields = List.filter (fun (k, _) -> k <> "storage") assoc in
38
+
let unknown_mems = List.map (fun (k, v) -> ((k, Jsont.Meta.none), v)) unknown_fields in
39
+
let unknown = Jsont.Object (unknown_mems, Jsont.Meta.none) in
40
+
Ok { storage; unknown }
41
+
| Some _ -> Error "Expected 'storage' field to be an object"
42
+
| None -> Ok { storage = []; unknown = Jsont.Object ([], Jsont.Meta.none) })
43
+
| _ -> Error "Expected JSON object for storage response"
44
+
in
45
+
let to_string { storage; unknown } =
46
+
(* Create storage object *)
47
+
let storage_fields = List.map (fun (k, v) ->
48
+
((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))
49
+
) storage in
50
+
let storage_obj = Jsont.Object (storage_fields, Jsont.Meta.none) in
51
+
52
+
(* Merge with unknown fields *)
53
+
let storage_mem = (("storage", Jsont.Meta.none), storage_obj) in
54
+
let unknown_mems = match unknown with
55
+
| Jsont.Object (fields, _) -> fields
56
+
| _ -> []
57
+
in
58
+
let json = Jsont.Object (storage_mem :: unknown_mems, Jsont.Meta.none) in
59
+
match Jsont_bytesrw.encode_string' Jsont.json json with
60
+
| Ok s -> s
61
+
| Error e -> failwith ("Failed to encode storage response: " ^ Jsont.Error.to_string e)
62
+
in
63
+
Jsont.of_of_string ~kind:"StorageResponse" of_string ~enc:to_string
64
+
12
65
let create client ~bot_email =
13
66
Log.info (fun m -> m "Creating bot storage for %s" bot_email);
14
67
let cache = Hashtbl.create 16 in
···
19
72
~path:"/api/v1/bot_storage"
20
73
() with
21
74
| Ok json ->
22
-
(match Zulip.Jsonu.get_object_opt (match json with `O f -> f | _ -> []) "storage" with
23
-
| Some storage_fields ->
75
+
(match Zulip.Encode.from_json storage_response_jsont json with
76
+
| Ok response ->
24
77
List.iter (fun (k, v) ->
25
-
match Zulip.Jsonu.to_string_safe v with
26
-
| Some value ->
27
-
Log.debug (fun m -> m "Loaded key from server: %s" k);
28
-
Hashtbl.add cache k value
29
-
| None -> ()
30
-
) storage_fields
31
-
| None -> ())
78
+
Log.debug (fun m -> m "Loaded key from server: %s" k);
79
+
Hashtbl.add cache k v
80
+
) response.storage
81
+
| Error msg ->
82
+
Log.warn (fun m -> m "Failed to parse storage response: %s" msg))
32
83
| Error e ->
33
84
Log.warn (fun m -> m "Failed to load existing storage: %s" (Zulip.error_message e)));
34
85
···
43
94
let encode_storage_update keys_values =
44
95
(* Build the storage object as JSON - the API expects storage={"key": "value"} *)
45
96
let storage_obj =
46
-
List.map (fun (k, v) -> (k, `String v)) keys_values
97
+
List.map (fun (k, v) -> ((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))) keys_values
47
98
in
48
-
let json_obj = `O storage_obj in
99
+
let json_obj = Jsont.Object (storage_obj, Jsont.Meta.none) in
49
100
50
-
(* Convert to JSON string using Ezjsonm *)
51
-
let json_str = Ezjsonm.to_string json_obj in
101
+
(* Convert to JSON string using Jsont_bytesrw *)
102
+
let json_str = Jsont_bytesrw.encode_string' Jsont.json json_obj |> Result.get_ok in
52
103
53
104
(* Return as form-encoded body: storage=<url-encoded-json> *)
54
105
"storage=" ^ Uri.pct_encode json_str
···
68
119
~path:"/api/v1/bot_storage"
69
120
~params () with
70
121
| Ok json ->
71
-
(match Zulip.Jsonu.get_object_opt (match json with `O f -> f | _ -> []) "storage" with
72
-
| Some storage_fields ->
73
-
(match Zulip.Jsonu.get_string_opt storage_fields key with
122
+
(match Zulip.Encode.from_json storage_response_jsont json with
123
+
| Ok response ->
124
+
(match List.assoc_opt key response.storage with
74
125
| Some value ->
75
126
(* Cache the value *)
76
127
Log.debug (fun m -> m "Retrieved key from API: %s" key);
···
79
130
| None ->
80
131
Log.debug (fun m -> m "Key not found in API: %s" key);
81
132
None)
82
-
| None -> None)
133
+
| Error msg ->
134
+
Log.warn (fun m -> m "Failed to parse storage response: %s" msg);
135
+
None)
83
136
| Error e ->
84
137
Log.warn (fun m -> m "Error fetching key %s: %s" key (Zulip.error_message e));
85
138
None
···
140
193
~path:"/api/v1/bot_storage"
141
194
() with
142
195
| Ok json ->
143
-
(match json with
144
-
| `O fields ->
145
-
(match List.assoc_opt "storage" fields with
146
-
| Some (`O storage_fields) ->
147
-
let api_keys = List.map fst storage_fields in
148
-
(* Merge with cache keys *)
149
-
let cache_keys = Hashtbl.fold (fun k _ acc -> k :: acc) t.cache [] in
150
-
let all_keys = List.sort_uniq String.compare (api_keys @ cache_keys) in
151
-
Ok all_keys
152
-
| _ -> Ok [])
153
-
| _ -> Ok [])
196
+
(match Zulip.Encode.from_json storage_response_jsont json with
197
+
| Ok response ->
198
+
let api_keys = List.map fst response.storage in
199
+
(* Merge with cache keys *)
200
+
let cache_keys = Hashtbl.fold (fun k _ acc -> k :: acc) t.cache [] in
201
+
let all_keys = List.sort_uniq String.compare (api_keys @ cache_keys) in
202
+
Ok all_keys
203
+
| Error msg ->
204
+
Log.warn (fun m -> m "Failed to parse storage response: %s" msg);
205
+
Ok [])
154
206
| Error e -> Error e
155
207
156
208
(* Flush all dirty keys to API *)
···
182
234
| Error e ->
183
235
Log.err (fun m -> m "Failed to flush storage: %s" (Zulip.error_message e));
184
236
Error e
185
-
end
237
+
end
+1
-1
stack/zulip/lib/zulip_bot/lib/dune
+1
-1
stack/zulip/lib/zulip_bot/lib/dune
+277
-88
stack/zulip/lib/zulip_bot/lib/message.ml
+277
-88
stack/zulip/lib/zulip_bot/lib/message.ml
···
1
-
(* Use Jsonm exclusively via Zulip.Jsonu utilities *)
1
+
(* Message parsing using Jsont codecs *)
2
2
3
3
let logs_src = Logs.Src.create "zulip_bot.message"
4
4
module Log = (val Logs.src_log logs_src : Logs.LOG)
···
10
10
email: string;
11
11
full_name: string;
12
12
short_name: string option;
13
+
unknown: Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
13
14
}
14
15
15
16
let user_id t = t.user_id
···
17
18
let full_name t = t.full_name
18
19
let short_name t = t.short_name
19
20
21
+
(* Jsont codec for User - handles both user_id and id fields *)
22
+
let jsont : t Jsont.t =
23
+
let of_string s =
24
+
match Jsont_bytesrw.decode_string' Jsont.json s with
25
+
| Error _ -> Error "Failed to decode JSON"
26
+
| Ok json ->
27
+
match json with
28
+
| Jsont.Object (fields, _) ->
29
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
30
+
let user_id =
31
+
match List.assoc_opt "user_id" assoc with
32
+
| Some (Jsont.Number (f, _)) -> Some (int_of_float f)
33
+
| _ ->
34
+
match List.assoc_opt "id" assoc with
35
+
| Some (Jsont.Number (f, _)) -> Some (int_of_float f)
36
+
| _ -> None
37
+
in
38
+
let email =
39
+
match List.assoc_opt "email" assoc with
40
+
| Some (Jsont.String (s, _)) -> Some s
41
+
| _ -> None
42
+
in
43
+
let full_name =
44
+
match List.assoc_opt "full_name" assoc with
45
+
| Some (Jsont.String (s, _)) -> Some s
46
+
| _ -> None
47
+
in
48
+
let short_name =
49
+
match List.assoc_opt "short_name" assoc with
50
+
| Some (Jsont.String (s, _)) -> Some s
51
+
| _ -> None
52
+
in
53
+
(match (user_id, email, full_name) with
54
+
| (Some user_id, Some email, Some full_name) ->
55
+
(* Keep unknown fields *)
56
+
let unknown_fields = List.filter (fun (k, _) ->
57
+
k <> "user_id" && k <> "id" && k <> "email" && k <> "full_name" && k <> "short_name"
58
+
) assoc in
59
+
let unknown_mems = List.map (fun (k, v) -> ((k, Jsont.Meta.none), v)) unknown_fields in
60
+
let unknown = Jsont.Object (unknown_mems, Jsont.Meta.none) in
61
+
Ok { user_id; email; full_name; short_name; unknown }
62
+
| _ -> Error "Missing required user fields")
63
+
| _ -> Error "Expected JSON object for user"
64
+
in
65
+
let to_string { user_id; email; full_name; short_name; unknown } =
66
+
let fields = [
67
+
(("user_id", Jsont.Meta.none), Jsont.Number (float_of_int user_id, Jsont.Meta.none));
68
+
(("email", Jsont.Meta.none), Jsont.String (email, Jsont.Meta.none));
69
+
(("full_name", Jsont.Meta.none), Jsont.String (full_name, Jsont.Meta.none));
70
+
] in
71
+
let fields = match short_name with
72
+
| Some sn -> (("short_name", Jsont.Meta.none), Jsont.String (sn, Jsont.Meta.none)) :: fields
73
+
| None -> fields
74
+
in
75
+
let unknown_mems = match unknown with
76
+
| Jsont.Object (mems, _) -> mems
77
+
| _ -> []
78
+
in
79
+
let json = Jsont.Object (fields @ unknown_mems, Jsont.Meta.none) in
80
+
match Jsont_bytesrw.encode_string' Jsont.json json with
81
+
| Ok s -> s
82
+
| Error e -> failwith ("Failed to encode user: " ^ Jsont.Error.to_string e)
83
+
in
84
+
Jsont.of_of_string ~kind:"User" of_string ~enc:to_string
85
+
20
86
let of_json (json : Zulip.json) : (t, Zulip.zerror) result =
21
-
let open Zulip.Jsonu_syntax in
22
-
(Zulip.Jsonu.with_object "user" @@ fun fields ->
23
-
let* user_id = (field fields "user_id" int) <|> (field fields "id" int) in
24
-
let* email = field fields "email" string in
25
-
let* full_name = field fields "full_name" string in
26
-
let* short_name = field_opt fields "short_name" string in
27
-
Ok { user_id; email; full_name; short_name }) json
87
+
match Zulip.Encode.from_json jsont json with
88
+
| Ok v -> Ok v
89
+
| Error msg -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg ())
28
90
end
29
91
30
92
(** Reaction representation *)
···
34
96
emoji_code: string;
35
97
reaction_type: string;
36
98
user_id: int;
99
+
unknown: Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
37
100
}
38
101
39
102
let emoji_name t = t.emoji_name
···
41
104
let reaction_type t = t.reaction_type
42
105
let user_id t = t.user_id
43
106
107
+
(* Jsont codec for Reaction - handles user_id in different locations *)
108
+
let jsont : t Jsont.t =
109
+
let of_string s =
110
+
match Jsont_bytesrw.decode_string' Jsont.json s with
111
+
| Error _ -> Error "Failed to decode JSON"
112
+
| Ok json ->
113
+
match json with
114
+
| Jsont.Object (fields, _) ->
115
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
116
+
let emoji_name =
117
+
match List.assoc_opt "emoji_name" assoc with
118
+
| Some (Jsont.String (s, _)) -> Some s
119
+
| _ -> None
120
+
in
121
+
let emoji_code =
122
+
match List.assoc_opt "emoji_code" assoc with
123
+
| Some (Jsont.String (s, _)) -> Some s
124
+
| _ -> None
125
+
in
126
+
let reaction_type =
127
+
match List.assoc_opt "reaction_type" assoc with
128
+
| Some (Jsont.String (s, _)) -> Some s
129
+
| _ -> None
130
+
in
131
+
(* user_id can be either directly in the object or nested in a "user" field *)
132
+
let user_id =
133
+
match List.assoc_opt "user_id" assoc with
134
+
| Some (Jsont.Number (f, _)) -> Some (int_of_float f)
135
+
| _ ->
136
+
match List.assoc_opt "user" assoc with
137
+
| Some (Jsont.Object (user_fields, _)) ->
138
+
let user_assoc = List.map (fun ((k, _), v) -> (k, v)) user_fields in
139
+
(match List.assoc_opt "user_id" user_assoc with
140
+
| Some (Jsont.Number (f, _)) -> Some (int_of_float f)
141
+
| _ -> None)
142
+
| _ -> None
143
+
in
144
+
(match (emoji_name, emoji_code, reaction_type, user_id) with
145
+
| (Some emoji_name, Some emoji_code, Some reaction_type, Some user_id) ->
146
+
(* Keep unknown fields *)
147
+
let unknown_fields = List.filter (fun (k, _) ->
148
+
k <> "emoji_name" && k <> "emoji_code" && k <> "reaction_type" && k <> "user_id" && k <> "user"
149
+
) assoc in
150
+
let unknown_mems = List.map (fun (k, v) -> ((k, Jsont.Meta.none), v)) unknown_fields in
151
+
let unknown = Jsont.Object (unknown_mems, Jsont.Meta.none) in
152
+
Ok { emoji_name; emoji_code; reaction_type; user_id; unknown }
153
+
| _ -> Error "Missing required reaction fields")
154
+
| _ -> Error "Expected JSON object for reaction"
155
+
in
156
+
let to_string { emoji_name; emoji_code; reaction_type; user_id; unknown } =
157
+
let fields = [
158
+
(("emoji_name", Jsont.Meta.none), Jsont.String (emoji_name, Jsont.Meta.none));
159
+
(("emoji_code", Jsont.Meta.none), Jsont.String (emoji_code, Jsont.Meta.none));
160
+
(("reaction_type", Jsont.Meta.none), Jsont.String (reaction_type, Jsont.Meta.none));
161
+
(("user_id", Jsont.Meta.none), Jsont.Number (float_of_int user_id, Jsont.Meta.none));
162
+
] in
163
+
let unknown_mems = match unknown with
164
+
| Jsont.Object (mems, _) -> mems
165
+
| _ -> []
166
+
in
167
+
let json = Jsont.Object (fields @ unknown_mems, Jsont.Meta.none) in
168
+
match Jsont_bytesrw.encode_string' Jsont.json json with
169
+
| Ok s -> s
170
+
| Error e -> failwith ("Failed to encode reaction: " ^ Jsont.Error.to_string e)
171
+
in
172
+
Jsont.of_of_string ~kind:"Reaction" of_string ~enc:to_string
173
+
44
174
let of_json (json : Zulip.json) : (t, Zulip.zerror) result =
45
-
let open Zulip.Jsonu_syntax in
46
-
(Zulip.Jsonu.with_object "reaction" @@ fun fields ->
47
-
let* emoji_name = field fields "emoji_name" string in
48
-
let* emoji_code = field fields "emoji_code" string in
49
-
let* reaction_type = field fields "reaction_type" string in
50
-
let* user_id =
51
-
(field fields "user_id" int) <|>
52
-
(match field fields "user" object_ with
53
-
| Ok user_obj -> field user_obj "user_id" int
54
-
| Error _ -> fail "user_id not found") in
55
-
Ok { emoji_name; emoji_code; reaction_type; user_id }) json
175
+
match Zulip.Encode.from_json jsont json with
176
+
| Ok v -> Ok v
177
+
| Error msg -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg ())
56
178
end
57
179
58
180
let parse_reaction_json json = Reaction.of_json json
···
96
218
97
219
(** Helper function to parse common fields *)
98
220
let parse_common json =
99
-
Zulip.Jsonu.parse_with_error "common fields" @@ fun () ->
100
-
(Zulip.Jsonu.with_object "message" @@ fun fields ->
101
-
let open Zulip.Jsonu_syntax in
102
-
let* id = field fields "id" int in
103
-
let* sender_id = field fields "sender_id" int in
104
-
let* sender_email = field fields "sender_email" string in
105
-
let* sender_full_name = field fields "sender_full_name" string in
106
-
let sender_short_name = field_opt fields "sender_short_name" string |? None in
107
-
let timestamp = field_or fields "timestamp" float 0.0 |? 0.0 in
108
-
let content = field_or fields "content" string "" |? "" in
109
-
let content_type = field_or fields "content_type" string "text/html" |? "text/html" in
221
+
match json with
222
+
| Jsont.Object (fields, _) ->
223
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
224
+
let get_int key =
225
+
match List.assoc_opt key assoc with
226
+
| Some (Jsont.Number (f, _)) -> Some (int_of_float f)
227
+
| _ -> None
228
+
in
229
+
let get_string key =
230
+
match List.assoc_opt key assoc with
231
+
| Some (Jsont.String (s, _)) -> Some s
232
+
| _ -> None
233
+
in
234
+
let get_float key default =
235
+
match List.assoc_opt key assoc with
236
+
| Some (Jsont.Number (f, _)) -> f
237
+
| _ -> default
238
+
in
239
+
let get_bool key default =
240
+
match List.assoc_opt key assoc with
241
+
| Some (Jsont.Bool (b, _)) -> b
242
+
| _ -> default
243
+
in
244
+
let get_array key =
245
+
match List.assoc_opt key assoc with
246
+
| Some (Jsont.Array (arr, _)) -> Some arr
247
+
| _ -> None
248
+
in
110
249
111
-
let reactions =
112
-
match Zulip.Jsonu.get_array_opt fields "reactions" with
113
-
| Some reactions_json ->
114
-
List.filter_map (fun r ->
115
-
match parse_reaction_json r with
116
-
| Ok reaction -> Some reaction
117
-
| Error err ->
118
-
Log.warn (fun m -> m "Failed to parse reaction: %s" (Zulip.error_message err));
119
-
None
120
-
) reactions_json
121
-
| None -> []
122
-
in
250
+
(match (get_int "id", get_int "sender_id", get_string "sender_email", get_string "sender_full_name") with
251
+
| (Some id, Some sender_id, Some sender_email, Some sender_full_name) ->
252
+
let sender_short_name = get_string "sender_short_name" in
253
+
let timestamp = get_float "timestamp" 0.0 in
254
+
let content = get_string "content" |> Option.value ~default:"" in
255
+
let content_type = get_string "content_type" |> Option.value ~default:"text/html" in
123
256
124
-
let submessages = Zulip.Jsonu.get_array_opt fields "submessages" |> Option.value ~default:[] in
257
+
let reactions =
258
+
match get_array "reactions" with
259
+
| Some reactions_json ->
260
+
List.filter_map (fun r ->
261
+
match parse_reaction_json r with
262
+
| Ok reaction -> Some reaction
263
+
| Error err ->
264
+
Log.warn (fun m -> m "Failed to parse reaction: %s" (Zulip.error_message err));
265
+
None
266
+
) reactions_json
267
+
| None -> []
268
+
in
125
269
126
-
let flags =
127
-
match Zulip.Jsonu.get_array_opt fields "flags" with
128
-
| Some flags_json -> List.filter_map Zulip.Jsonu.to_string_safe flags_json
129
-
| None -> []
130
-
in
270
+
let submessages = get_array "submessages" |> Option.value ~default:[] in
131
271
132
-
let is_me_message = field_or fields "is_me_message" bool false |? false in
133
-
let client = field_or fields "client" string "" |? "" in
134
-
let gravatar_hash = field_or fields "gravatar_hash" string "" |? "" in
135
-
let avatar_url = field_opt fields "avatar_url" string |? None in
272
+
let flags =
273
+
match get_array "flags" with
274
+
| Some flags_json ->
275
+
List.filter_map (fun f ->
276
+
match f with
277
+
| Jsont.String (s, _) -> Some s
278
+
| _ -> None
279
+
) flags_json
280
+
| None -> []
281
+
in
136
282
137
-
Ok {
138
-
id; sender_id; sender_email; sender_full_name; sender_short_name;
139
-
timestamp; content; content_type; reactions; submessages;
140
-
flags; is_me_message; client; gravatar_hash; avatar_url
141
-
}) json
283
+
let is_me_message = get_bool "is_me_message" false in
284
+
let client = get_string "client" |> Option.value ~default:"" in
285
+
let gravatar_hash = get_string "gravatar_hash" |> Option.value ~default:"" in
286
+
let avatar_url = get_string "avatar_url" in
287
+
288
+
Ok {
289
+
id; sender_id; sender_email; sender_full_name; sender_short_name;
290
+
timestamp; content; content_type; reactions; submessages;
291
+
flags; is_me_message; client; gravatar_hash; avatar_url
292
+
}
293
+
| _ -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg:"Missing required message fields" ()))
294
+
| _ -> Error (Zulip.create_error ~code:(Other "json_parse_error") ~msg:"Expected JSON object for message" ())
142
295
143
296
(** JSON parsing *)
144
297
let of_json json =
145
-
Log.debug (fun m -> m "Parsing message JSON: %s" (Zulip.Jsonu.to_string_pretty json));
298
+
(* Helper to pretty print JSON without using jsonu *)
299
+
let json_str =
300
+
match Jsont_bytesrw.encode_string' Jsont.json json with
301
+
| Ok s -> s
302
+
| Error _ -> "<error encoding json>"
303
+
in
304
+
Log.debug (fun m -> m "Parsing message JSON: %s" json_str);
146
305
147
-
let open Zulip.Jsonu_syntax in
148
306
match parse_common json with
149
307
| Error err -> Error (Zulip.error_message err)
150
308
| Ok common ->
151
-
(Zulip.Jsonu.parse_with_error "message type" @@ fun () ->
152
-
(Zulip.Jsonu.with_object "message" @@ fun fields ->
153
-
match Zulip.Jsonu.get_string fields "type" with
154
-
| Ok "private" ->
155
-
let* recipient_json = field fields "display_recipient" (array (fun x -> Ok x)) in
156
-
let users = List.filter_map (fun u ->
157
-
match parse_user_json u with
158
-
| Ok user -> Some user
159
-
| Error err ->
160
-
Log.warn (fun m -> m "Failed to parse user in display_recipient: %s" (Zulip.error_message err));
161
-
None
162
-
) recipient_json in
309
+
match json with
310
+
| Jsont.Object (fields, _) ->
311
+
let assoc = List.map (fun ((k, _), v) -> (k, v)) fields in
312
+
let msg_type =
313
+
match List.assoc_opt "type" assoc with
314
+
| Some (Jsont.String (s, _)) -> Some s
315
+
| _ -> None
316
+
in
317
+
(match msg_type with
318
+
| Some "private" ->
319
+
(match List.assoc_opt "display_recipient" assoc with
320
+
| Some (Jsont.Array (recipient_json, _)) ->
321
+
let users = List.filter_map (fun u ->
322
+
match parse_user_json u with
323
+
| Ok user -> Some user
324
+
| Error err ->
325
+
Log.warn (fun m -> m "Failed to parse user in display_recipient: %s" (Zulip.error_message err));
326
+
None
327
+
) recipient_json in
163
328
164
-
if List.length users = 0 && List.length recipient_json > 0 then
165
-
fail "Failed to parse any users in display_recipient"
166
-
else
167
-
Ok (Private { common; display_recipient = users })
329
+
if List.length users = 0 && List.length recipient_json > 0 then
330
+
Error "Failed to parse any users in display_recipient"
331
+
else
332
+
Ok (Private { common; display_recipient = users })
333
+
| _ ->
334
+
Log.warn (fun m -> m "display_recipient is not an array for private message");
335
+
Ok (Unknown { common; raw_json = json }))
168
336
169
-
| Ok "stream" ->
170
-
let* display_recipient = field fields "display_recipient" string in
171
-
let* stream_id = field fields "stream_id" int in
172
-
let* subject = field fields "subject" string in
173
-
Ok (Stream { common; display_recipient; stream_id; subject })
337
+
| Some "stream" ->
338
+
let display_recipient =
339
+
match List.assoc_opt "display_recipient" assoc with
340
+
| Some (Jsont.String (s, _)) -> Some s
341
+
| _ -> None
342
+
in
343
+
let stream_id =
344
+
match List.assoc_opt "stream_id" assoc with
345
+
| Some (Jsont.Number (f, _)) -> Some (int_of_float f)
346
+
| _ -> None
347
+
in
348
+
let subject =
349
+
match List.assoc_opt "subject" assoc with
350
+
| Some (Jsont.String (s, _)) -> Some s
351
+
| _ -> None
352
+
in
353
+
(match (display_recipient, stream_id, subject) with
354
+
| (Some display_recipient, Some stream_id, Some subject) ->
355
+
Ok (Stream { common; display_recipient; stream_id; subject })
356
+
| _ ->
357
+
Log.warn (fun m -> m "Missing required fields for stream message");
358
+
Ok (Unknown { common; raw_json = json }))
174
359
175
-
| Ok unknown_type ->
176
-
Log.warn (fun m -> m "Unknown message type: %s" unknown_type);
177
-
Ok (Unknown { common; raw_json = json })
360
+
| Some unknown_type ->
361
+
Log.warn (fun m -> m "Unknown message type: %s" unknown_type);
362
+
Ok (Unknown { common; raw_json = json })
178
363
179
-
| Error _ ->
180
-
Log.warn (fun m -> m "No message type field found");
181
-
Ok (Unknown { common; raw_json = json })
182
-
) json) |> Result.map_error Zulip.error_message
364
+
| None ->
365
+
Log.warn (fun m -> m "No message type field found");
366
+
Ok (Unknown { common; raw_json = json }))
367
+
| _ -> Error "Expected JSON object for message"
183
368
184
369
(** Accessor functions *)
185
370
let get_common = function
···
363
548
(** Pretty print JSON for debugging *)
364
549
let pp_json_debug ppf json =
365
550
let open Fmt in
366
-
let json_str = Zulip.Jsonu.to_string_pretty json in
551
+
let json_str =
552
+
match Jsont_bytesrw.encode_string' Jsont.json json with
553
+
| Ok s -> s
554
+
| Error _ -> "<error encoding json>"
555
+
in
367
556
pf ppf "@[<v>%a@.%a@]"
368
557
(styled `Bold (styled (`Fg `Blue) string)) "Raw JSON:"
369
558
(styled (`Fg `Black) string) json_str
+10
stack/zulip/lib/zulip_bot/lib/message.mli
+10
stack/zulip/lib/zulip_bot/lib/message.mli
···
7
7
email: string;
8
8
full_name: string;
9
9
short_name: string option;
10
+
unknown: Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
10
11
}
11
12
12
13
val user_id : t -> int
13
14
val email : t -> string
14
15
val full_name : t -> string
15
16
val short_name : t -> string option
17
+
18
+
(** Jsont codec for User *)
19
+
val jsont : t Jsont.t
20
+
16
21
val of_json : Zulip.json -> (t, Zulip.zerror) result
17
22
end
18
23
···
23
28
emoji_code: string;
24
29
reaction_type: string;
25
30
user_id: int;
31
+
unknown: Jsont.json; (** Unknown/extra JSON fields preserved during parsing *)
26
32
}
27
33
28
34
val emoji_name : t -> string
29
35
val emoji_code : t -> string
30
36
val reaction_type : t -> string
31
37
val user_id : t -> int
38
+
39
+
(** Jsont codec for Reaction *)
40
+
val jsont : t Jsont.t
41
+
32
42
val of_json : Zulip.json -> (t, Zulip.zerror) result
33
43
end
34
44
+30
stack/zulip/zulip.opam
+30
stack/zulip/zulip.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "OCaml bindings for the Zulip REST API"
4
+
description:
5
+
"High-quality OCaml bindings to the Zulip REST API using EIO for async operations"
6
+
depends: [
7
+
"ocaml"
8
+
"dune" {>= "3.0"}
9
+
"eio"
10
+
"requests"
11
+
"uri"
12
+
"base64"
13
+
"alcotest" {with-test}
14
+
"eio_main" {with-test}
15
+
"odoc" {with-doc}
16
+
]
17
+
build: [
18
+
["dune" "subst"] {dev}
19
+
[
20
+
"dune"
21
+
"build"
22
+
"-p"
23
+
name
24
+
"-j"
25
+
jobs
26
+
"@install"
27
+
"@runtest" {with-test}
28
+
"@doc" {with-doc}
29
+
]
30
+
]
+26
stack/zulip/zulip_bot.opam
+26
stack/zulip/zulip_bot.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "OCaml bot framework for Zulip"
4
+
description: "Interactive bot framework built on the OCaml Zulip library"
5
+
depends: [
6
+
"ocaml"
7
+
"dune" {>= "3.0"}
8
+
"zulip"
9
+
"eio"
10
+
"alcotest" {with-test}
11
+
"odoc" {with-doc}
12
+
]
13
+
build: [
14
+
["dune" "subst"] {dev}
15
+
[
16
+
"dune"
17
+
"build"
18
+
"-p"
19
+
name
20
+
"-j"
21
+
jobs
22
+
"@install"
23
+
"@runtest" {with-test}
24
+
"@doc" {with-doc}
25
+
]
26
+
]
+29
stack/zulip/zulip_botserver.opam
+29
stack/zulip/zulip_botserver.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "OCaml bot server for running multiple Zulip bots"
4
+
description:
5
+
"HTTP server for running multiple Zulip bots with webhook support"
6
+
depends: [
7
+
"ocaml"
8
+
"dune" {>= "3.0"}
9
+
"zulip"
10
+
"zulip_bot"
11
+
"eio"
12
+
"requests"
13
+
"alcotest" {with-test}
14
+
"odoc" {with-doc}
15
+
]
16
+
build: [
17
+
["dune" "subst"] {dev}
18
+
[
19
+
"dune"
20
+
"build"
21
+
"-p"
22
+
name
23
+
"-j"
24
+
jobs
25
+
"@install"
26
+
"@runtest" {with-test}
27
+
"@doc" {with-doc}
28
+
]
29
+
]