this repo has no description
more
+2951
-2139
-2
CLAUDE.md
-2
CLAUDE.md
···
1
-
This is a monorepo of a collection of OCaml libraries that should all work together, but they are in different stages of porting. Ultimately, the goal is to use Eio for everything and move away from Lwt entirely. For HTTP(S) requests the idea is to use River as the main high evel 'http requests' API, so anything using Cohttp or other HTTP fetchers will need to be ported.
2
-
+232
stack/TODO.md
+232
stack/TODO.md
···
1
+
# Production Quality TODO
2
+
3
+
This document tracks remaining tasks to make the immutable Requests.t and refactored library patterns production-ready.
4
+
5
+
## High Priority
6
+
7
+
### 1. Update Immiche README.md ⚠️
8
+
**Status:** Outdated
9
+
**Location:** `immiche/README.md`
10
+
11
+
The README still documents the old API (passing `~sw ~clock ~net ~base_url ~api_key` on every call) instead of the new session-based pattern.
12
+
13
+
**Tasks:**
14
+
- [ ] Update API signatures to show `create` function
15
+
- [ ] Update example code to show session creation
16
+
- [ ] Document connection pooling benefits
17
+
- [ ] Update "Implementation Notes" to mention `Requests.t` instead of `Requests.One`
18
+
- [ ] Add example of sharing sessions across multiple libraries
19
+
20
+
**Example of needed change:**
21
+
```ocaml
22
+
(* OLD - documented in README *)
23
+
let people = Immiche.fetch_people ~sw ~clock ~net ~base_url ~api_key
24
+
25
+
(* NEW - what actually works now *)
26
+
let client = Immiche.create ~sw ~env ~base_url ~api_key () in
27
+
let people = Immiche.fetch_people client
28
+
```
29
+
30
+
### 2. Improve Error Handling in Immiche
31
+
**Status:** Inconsistent
32
+
**Location:** `immiche/immiche.ml:79,92,133`
33
+
34
+
Currently uses `failwith` for HTTP errors instead of returning Result types consistently.
35
+
36
+
**Issues:**
37
+
- `fetch_people`, `fetch_person`, `search_person` use `failwith` for HTTP errors
38
+
- `download_thumbnail` correctly returns `Result`
39
+
- Inconsistent error handling makes it hard to gracefully handle failures
40
+
41
+
**Tasks:**
42
+
- [ ] Change `fetch_people` to return `(people_response, [> `Msg of string]) result`
43
+
- [ ] Change `fetch_person` to return `(person, [> `Msg of string]) result`
44
+
- [ ] Change `search_person` to return `(person list, [> `Msg of string]) result`
45
+
- [ ] Update `immiche/immiche.mli` with new signatures
46
+
- [ ] Update `bushel/bin/bushel_faces.ml` to handle Result types
47
+
- [ ] Document error cases in docstrings
48
+
49
+
### 3. Add Type Aliases for Verbose Signatures
50
+
**Status:** Verbose
51
+
**Location:** `immiche/immiche.mli`, `zotero-translation/zotero_translation.mli`
52
+
53
+
Type signatures like `([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t` are extremely verbose.
54
+
55
+
**Tasks:**
56
+
- [ ] Consider adding type aliases:
57
+
```ocaml
58
+
type client =
59
+
([> float Eio.Time.clock_ty ] Eio.Resource.t,
60
+
[> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t
61
+
62
+
val fetch_people : client -> people_response
63
+
```
64
+
- [ ] Evaluate if this improves or harms the API (might hide important type info)
65
+
- [ ] If beneficial, apply to both Immiche and zotero-translation
66
+
67
+
## Medium Priority
68
+
69
+
### 4. Add Tests for New Immiche Pattern
70
+
**Status:** No tests
71
+
**Location:** None - needs creation
72
+
73
+
The Immiche library was refactored but has no tests.
74
+
75
+
**Tasks:**
76
+
- [ ] Create `immiche/test/test_immiche.ml`
77
+
- [ ] Add test for `create` function
78
+
- [ ] Add tests for all API functions with mocked responses
79
+
- [ ] Test connection pooling behavior (multiple requests reuse connections)
80
+
- [ ] Test session sharing (derived sessions share pools)
81
+
- [ ] Add to dune test suite
82
+
83
+
### 5. Verify Zotero-translation with Immutable Requests.t
84
+
**Status:** Unknown compatibility
85
+
**Location:** `zotero-translation/`
86
+
87
+
Zotero-translation was already using session pattern before we made Requests.t immutable. Need to verify it still works correctly.
88
+
89
+
**Tasks:**
90
+
- [ ] Review if zotero-translation needs updates for immutable Requests.t
91
+
- [ ] Check if any derived sessions are created (and if pools are shared correctly)
92
+
- [ ] Add tests if missing
93
+
- [ ] Document session sharing pattern if used
94
+
95
+
### 6. Document Thread Safety / Concurrency Model
96
+
**Status:** Unclear
97
+
**Location:** Documentation
98
+
99
+
With immutable sessions that share mutable cookie_jar and statistics, the concurrency model needs documentation.
100
+
101
+
**Tasks:**
102
+
- [ ] Document that derived sessions share:
103
+
- Connection pools (intentional - for performance)
104
+
- Cookie jar (intentional - session state)
105
+
- Statistics (intentional - unified monitoring)
106
+
- [ ] Document that cookie_mutex protects concurrent cookie access
107
+
- [ ] Clarify if derived sessions can be used safely across Eio fibers
108
+
- [ ] Add concurrency examples to documentation
109
+
110
+
### 7. Enhanced API Documentation
111
+
**Status:** Basic
112
+
**Location:** All `.mli` files
113
+
114
+
Current documentation is minimal. Could add more examples and edge case documentation.
115
+
116
+
**Tasks:**
117
+
- [ ] Add usage examples to `requests/lib/requests.mli` showing:
118
+
- Creating base session
119
+
- Deriving sessions with different configs
120
+
- Sharing pools across derived sessions
121
+
- [ ] Document what happens when you derive from derived sessions
122
+
- [ ] Add performance notes about connection pooling
123
+
- [ ] Document cookie handling behavior
124
+
125
+
## Low Priority
126
+
127
+
### 8. Consider Immutable Statistics
128
+
**Status:** Design decision
129
+
**Location:** `requests/lib/requests.ml:51-53`
130
+
131
+
Statistics (requests_made, total_time, retries_count) are still mutable and shared across derived sessions.
132
+
133
+
**Trade-offs:**
134
+
- **Current (mutable):** Simple, tracks total usage across all derived sessions
135
+
- **Alternative (immutable):** Would require returning `(Response.t * t)` from all request functions
136
+
137
+
**Tasks:**
138
+
- [ ] Evaluate if immutable statistics would be valuable
139
+
- [ ] If yes, design API that returns updated sessions from request functions
140
+
- [ ] If no, document the design decision and rationale
141
+
142
+
### 9. Add Examples Directory
143
+
**Status:** No standalone examples
144
+
**Location:** None
145
+
146
+
Would be helpful to have example code showing common patterns.
147
+
148
+
**Tasks:**
149
+
- [ ] Create `examples/` directory
150
+
- [ ] Add `examples/immiche_basic.ml` - basic Immiche usage
151
+
- [ ] Add `examples/immiche_advanced.ml` - session sharing across APIs
152
+
- [ ] Add `examples/requests_sessions.ml` - derived sessions with shared pools
153
+
- [ ] Add `examples/zotero_immiche_shared.ml` - sharing pools between libraries
154
+
- [ ] Ensure examples build and run
155
+
156
+
### 10. Performance Benchmarks
157
+
**Status:** No benchmarks
158
+
**Location:** None
159
+
160
+
Would be valuable to have benchmarks showing connection pooling benefits.
161
+
162
+
**Tasks:**
163
+
- [ ] Create benchmark comparing:
164
+
- Requests.One (no pooling) vs Requests.t (with pooling)
165
+
- Single session vs derived sessions (verify pool sharing)
166
+
- Sequential vs parallel requests
167
+
- [ ] Document performance characteristics
168
+
- [ ] Add to CI if significant
169
+
170
+
## Breaking Changes Documented
171
+
172
+
### Immiche API (Breaking)
173
+
**Old API:**
174
+
```ocaml
175
+
val fetch_people :
176
+
sw:Eio.Switch.t ->
177
+
clock:_ Eio.Time.clock ->
178
+
net:_ Eio.Net.t ->
179
+
base_url:string ->
180
+
api_key:string ->
181
+
people_response
182
+
```
183
+
184
+
**New API:**
185
+
```ocaml
186
+
val create :
187
+
sw:Eio.Switch.t ->
188
+
env:< clock:_; net:_; fs:_; .. > ->
189
+
?requests_session:_ Requests.t ->
190
+
base_url:string ->
191
+
api_key:string ->
192
+
unit -> t
193
+
194
+
val fetch_people : t -> people_response
195
+
```
196
+
197
+
**Migration Required:**
198
+
- All Immiche users must update to create a client first
199
+
- Only known usage: `bushel/bin/bushel_faces.ml` (already updated)
200
+
201
+
### Requests Configuration Functions (Breaking)
202
+
**Old API:**
203
+
```ocaml
204
+
val set_auth : t -> Auth.t -> unit
205
+
```
206
+
207
+
**New API:**
208
+
```ocaml
209
+
val set_auth : t -> Auth.t -> t
210
+
```
211
+
212
+
**Migration Required:**
213
+
- Must capture returned session: `let req = Requests.set_auth req auth`
214
+
- All usages updated: ocurl.ml, test_requests.ml, jmap_client.ml
215
+
216
+
## Notes
217
+
218
+
- **Cookie handling:** Still mutable via shared cookie_jar - this is intentional for session state
219
+
- **Statistics:** Still mutable and shared - tracks total usage across derived sessions
220
+
- **Connection pools:** Shared across all derived sessions - major performance benefit
221
+
- **No backward compatibility:** Breaking changes are acceptable for this monorepo
222
+
223
+
## Completion Checklist
224
+
225
+
Before considering this production-ready:
226
+
227
+
- [ ] High priority items completed
228
+
- [ ] README.md updated for Immiche
229
+
- [ ] Error handling consistent across Immiche
230
+
- [ ] At least basic tests added for Immiche
231
+
- [ ] Documentation covers concurrency model
232
+
- [ ] All examples in docs are verified to work
+121
-132
stack/bushel/bin/bushel_doi.ml
+121
-132
stack/bushel/bin/bushel_doi.ml
···
1
1
module ZT = Zotero_translation
2
-
open Lwt.Infix
3
2
module J = Ezjsonm
4
3
open Cmdliner
5
4
···
43
42
let resolve_doi zt ~verbose doi =
44
43
Printf.printf "Resolving DOI: %s\n%!" doi;
45
44
let doi_url = Printf.sprintf "https://doi.org/%s" doi in
46
-
Lwt.catch
47
-
(fun () ->
48
-
ZT.json_of_doi zt ~slug:"temp" doi >>= fun json ->
49
-
if verbose then begin
50
-
Printf.printf " Raw Zotero response:\n%s\n%!" (J.value_to_string json)
51
-
end;
52
-
try
53
-
let keys = J.get_dict (json :> J.value) in
54
-
let title = J.find json ["title"] |> J.get_string in
55
-
let authors = J.find json ["author"] |> J.get_list J.get_string in
56
-
let year = J.find json ["year"] |> J.get_string |> int_of_string in
57
-
let bibtype = J.find json ["bibtype"] |> J.get_string in
58
-
let publisher =
59
-
try
60
-
(* Try journal first, then booktitle, then publisher *)
61
-
match List.assoc_opt "journal" keys with
62
-
| Some j -> J.get_string j
45
+
try
46
+
let json = ZT.json_of_doi zt ~slug:"temp" doi in
47
+
if verbose then begin
48
+
Printf.printf " Raw Zotero response:\n%s\n%!" (J.value_to_string json)
49
+
end;
50
+
try
51
+
let keys = J.get_dict (json :> J.value) in
52
+
let title = J.find json ["title"] |> J.get_string in
53
+
let authors = J.find json ["author"] |> J.get_list J.get_string in
54
+
let year = J.find json ["year"] |> J.get_string |> int_of_string in
55
+
let bibtype = J.find json ["bibtype"] |> J.get_string in
56
+
let publisher =
57
+
try
58
+
(* Try journal first, then booktitle, then publisher *)
59
+
match List.assoc_opt "journal" keys with
60
+
| Some j -> J.get_string j
61
+
| None ->
62
+
match List.assoc_opt "booktitle" keys with
63
+
| Some b -> J.get_string b
63
64
| None ->
64
-
match List.assoc_opt "booktitle" keys with
65
-
| Some b -> J.get_string b
66
-
| None ->
67
-
match List.assoc_opt "publisher" keys with
68
-
| Some p -> J.get_string p
69
-
| None -> ""
70
-
with _ -> ""
71
-
in
72
-
let entry = Bushel.Doi_entry.create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ~source_urls:[doi_url] () in
73
-
Printf.printf " ✓ Resolved: %s (%d)\n%!" title year;
74
-
Lwt.return entry
75
-
with e ->
76
-
Printf.eprintf " ✗ Failed to parse response for %s: %s\n%!" doi (Printexc.to_string e);
77
-
Lwt.return (Bushel.Doi_entry.create_failed ~doi ~error:(Printexc.to_string e) ~source_urls:[doi_url] ())
78
-
)
79
-
(fun exn ->
80
-
Printf.eprintf " ✗ Failed to resolve %s: %s\n%!" doi (Printexc.to_string exn);
81
-
Lwt.return (Bushel.Doi_entry.create_failed ~doi ~error:(Printexc.to_string exn) ~source_urls:[doi_url] ())
82
-
)
65
+
match List.assoc_opt "publisher" keys with
66
+
| Some p -> J.get_string p
67
+
| None -> ""
68
+
with _ -> ""
69
+
in
70
+
let entry = Bushel.Doi_entry.create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ~source_urls:[doi_url] () in
71
+
Printf.printf " ✓ Resolved: %s (%d)\n%!" title year;
72
+
entry
73
+
with e ->
74
+
Printf.eprintf " ✗ Failed to parse response for %s: %s\n%!" doi (Printexc.to_string e);
75
+
Bushel.Doi_entry.create_failed ~doi ~error:(Printexc.to_string e) ~source_urls:[doi_url] ()
76
+
with exn ->
77
+
Printf.eprintf " ✗ Failed to resolve %s: %s\n%!" doi (Printexc.to_string exn);
78
+
Bushel.Doi_entry.create_failed ~doi ~error:(Printexc.to_string exn) ~source_urls:[doi_url] ()
83
79
84
80
(* Resolve a publisher URL via Zotero /web endpoint *)
85
81
let resolve_url zt ~verbose url =
86
82
Printf.printf "Resolving URL: %s\n%!" url;
87
-
Lwt.catch
88
-
(fun () ->
89
-
(* Use Zotero's resolve_url which calls /web endpoint with the URL directly *)
90
-
ZT.resolve_url zt url >>= function
91
-
| Error (`Msg err) ->
92
-
Printf.eprintf " ✗ Failed to resolve URL: %s\n%!" err;
93
-
Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:err ~source_urls:[url] ())
94
-
| Ok json ->
95
-
if verbose then begin
96
-
Printf.printf " Raw Zotero response:\n%s\n%!" (J.value_to_string json)
97
-
end;
98
-
try
99
-
(* Extract metadata from the JSON response *)
100
-
let json_list = match json with
101
-
| `A lst -> lst
102
-
| single -> [single]
83
+
try
84
+
(* Use Zotero's resolve_url which calls /web endpoint with the URL directly *)
85
+
match ZT.resolve_url zt url with
86
+
| Error (`Msg err) ->
87
+
Printf.eprintf " ✗ Failed to resolve URL: %s\n%!" err;
88
+
Bushel.Doi_entry.create_failed ~doi:url ~error:err ~source_urls:[url] ()
89
+
| Ok json ->
90
+
if verbose then begin
91
+
Printf.printf " Raw Zotero response:\n%s\n%!" (J.value_to_string (json :> J.value))
92
+
end;
93
+
try
94
+
(* Extract metadata from the JSON response *)
95
+
let json_list = match json with
96
+
| `A lst -> lst
97
+
| single -> [(single :> J.value)]
98
+
in
99
+
match json_list with
100
+
| [] ->
101
+
Printf.eprintf " ✗ Empty response\n%!";
102
+
Bushel.Doi_entry.create_failed ~doi:url ~error:"Empty response" ~source_urls:[url] ()
103
+
| item :: _ ->
104
+
(* Extract DOI if present, otherwise use URL *)
105
+
let doi = try J.find item ["DOI"] |> J.get_string with _ ->
106
+
try J.find item ["doi"] |> J.get_string with _ -> url
107
+
in
108
+
let title = try J.find item ["title"] |> J.get_string with _ ->
109
+
"Unknown Title"
110
+
in
111
+
(* Extract authors from Zotero's "creators" field *)
112
+
let authors = try
113
+
J.find item ["creators"] |> J.get_list (fun creator_obj ->
114
+
try
115
+
let last_name = J.find creator_obj ["lastName"] |> J.get_string in
116
+
let first_name = try J.find creator_obj ["firstName"] |> J.get_string with _ -> "" in
117
+
if first_name = "" then last_name else first_name ^ " " ^ last_name
118
+
with _ -> "Unknown Author"
119
+
)
120
+
with _ -> []
121
+
in
122
+
(* Extract year from Zotero's "date" field *)
123
+
(* Handles both ISO format "2025-07" and text format "November 28, 2023" *)
124
+
let year = try
125
+
let date_str = J.find item ["date"] |> J.get_string in
126
+
(* First try splitting on '-' for ISO dates like "2025-07" or "2024-11-04" *)
127
+
let parts = String.split_on_char '-' date_str in
128
+
match parts with
129
+
| year_str :: _ when String.length year_str = 4 ->
130
+
(try int_of_string year_str with _ -> 0)
131
+
| _ ->
132
+
(* Try splitting on space and comma for dates like "November 28, 2023" *)
133
+
let space_parts = String.split_on_char ' ' date_str in
134
+
let year_candidate = List.find_opt (fun s ->
135
+
let s = String.trim (String.map (fun c -> if c = ',' then ' ' else c) s) in
136
+
String.length s = 4 && String.for_all (function '0'..'9' -> true | _ -> false) s
137
+
) space_parts in
138
+
(match year_candidate with
139
+
| Some year_str -> int_of_string (String.trim year_str)
140
+
| None -> 0)
141
+
with _ -> 0
103
142
in
104
-
match json_list with
105
-
| [] ->
106
-
Printf.eprintf " ✗ Empty response\n%!";
107
-
Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:"Empty response" ~source_urls:[url] ())
108
-
| item :: _ ->
109
-
(* Extract DOI if present, otherwise use URL *)
110
-
let doi = try J.find item ["DOI"] |> J.get_string with _ ->
111
-
try J.find item ["doi"] |> J.get_string with _ -> url
112
-
in
113
-
let title = try J.find item ["title"] |> J.get_string with _ ->
114
-
"Unknown Title"
115
-
in
116
-
(* Extract authors from Zotero's "creators" field *)
117
-
let authors = try
118
-
J.find item ["creators"] |> J.get_list (fun creator_obj ->
119
-
try
120
-
let last_name = J.find creator_obj ["lastName"] |> J.get_string in
121
-
let first_name = try J.find creator_obj ["firstName"] |> J.get_string with _ -> "" in
122
-
if first_name = "" then last_name else first_name ^ " " ^ last_name
123
-
with _ -> "Unknown Author"
124
-
)
125
-
with _ -> []
126
-
in
127
-
(* Extract year from Zotero's "date" field *)
128
-
(* Handles both ISO format "2025-07" and text format "November 28, 2023" *)
129
-
let year = try
130
-
let date_str = J.find item ["date"] |> J.get_string in
131
-
(* First try splitting on '-' for ISO dates like "2025-07" or "2024-11-04" *)
132
-
let parts = String.split_on_char '-' date_str in
133
-
match parts with
134
-
| year_str :: _ when String.length year_str = 4 ->
135
-
(try int_of_string year_str with _ -> 0)
136
-
| _ ->
137
-
(* Try splitting on space and comma for dates like "November 28, 2023" *)
138
-
let space_parts = String.split_on_char ' ' date_str in
139
-
let year_candidate = List.find_opt (fun s ->
140
-
let s = String.trim (String.map (fun c -> if c = ',' then ' ' else c) s) in
141
-
String.length s = 4 && String.for_all (function '0'..'9' -> true | _ -> false) s
142
-
) space_parts in
143
-
(match year_candidate with
144
-
| Some year_str -> int_of_string (String.trim year_str)
145
-
| None -> 0)
146
-
with _ -> 0
147
-
in
148
-
(* Extract type/bibtype from Zotero's "itemType" field *)
149
-
let bibtype = try J.find item ["itemType"] |> J.get_string with _ -> "article" in
150
-
(* Extract publisher/journal from Zotero's "publicationTitle" field *)
151
-
let publisher = try
152
-
J.find item ["publicationTitle"] |> J.get_string
153
-
with _ -> ""
154
-
in
155
-
(* Include both the original URL and the DOI URL in source_urls *)
156
-
let doi_url = if doi = url then [] else [Printf.sprintf "https://doi.org/%s" doi] in
157
-
let source_urls = url :: doi_url in
158
-
let entry = Bushel.Doi_entry.create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ~source_urls () in
159
-
Printf.printf " ✓ Resolved: %s (%d) [DOI: %s]\n%!" title year doi;
160
-
Lwt.return entry
161
-
with e ->
162
-
Printf.eprintf " ✗ Failed to parse response: %s\n%!" (Printexc.to_string e);
163
-
Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:(Printexc.to_string e) ~source_urls:[url] ())
164
-
)
165
-
(fun exn ->
166
-
Printf.eprintf " ✗ Failed to resolve %s: %s\n%!" url (Printexc.to_string exn);
167
-
Lwt.return (Bushel.Doi_entry.create_failed ~doi:url ~error:(Printexc.to_string exn) ~source_urls:[url] ())
168
-
)
143
+
(* Extract type/bibtype from Zotero's "itemType" field *)
144
+
let bibtype = try J.find item ["itemType"] |> J.get_string with _ -> "article" in
145
+
(* Extract publisher/journal from Zotero's "publicationTitle" field *)
146
+
let publisher = try
147
+
J.find item ["publicationTitle"] |> J.get_string
148
+
with _ -> ""
149
+
in
150
+
(* Include both the original URL and the DOI URL in source_urls *)
151
+
let doi_url = if doi = url then [] else [Printf.sprintf "https://doi.org/%s" doi] in
152
+
let source_urls = url :: doi_url in
153
+
let entry = Bushel.Doi_entry.create_resolved ~doi ~title ~authors ~year ~bibtype ~publisher ~source_urls () in
154
+
Printf.printf " ✓ Resolved: %s (%d) [DOI: %s]\n%!" title year doi;
155
+
entry
156
+
with e ->
157
+
Printf.eprintf " ✗ Failed to parse response: %s\n%!" (Printexc.to_string e);
158
+
Bushel.Doi_entry.create_failed ~doi:url ~error:(Printexc.to_string e) ~source_urls:[url] ()
159
+
with exn ->
160
+
Printf.eprintf " ✗ Failed to resolve %s: %s\n%!" url (Printexc.to_string exn);
161
+
Bushel.Doi_entry.create_failed ~doi:url ~error:(Printexc.to_string exn) ~source_urls:[url] ()
169
162
170
163
let run base_dir force verbose =
171
164
Printf.printf "Loading bushel database...\n%!";
···
222
215
end else begin
223
216
Printf.printf "Resolving %d DOI(s) and %d URL(s)...\n%!" (List.length dois_to_resolve) (List.length urls_to_resolve);
224
217
225
-
let zt = ZT.v "http://svr-avsm2-eeg-ce:1969" in
226
-
227
-
(* Resolve all DOIs *)
228
-
let resolved_doi_entries_lwt =
229
-
Lwt_list.map_s (resolve_doi zt ~verbose) dois_to_resolve
230
-
in
231
-
232
-
(* Resolve all publisher URLs *)
233
-
let resolved_url_entries_lwt =
234
-
Lwt_list.map_s (resolve_url zt ~verbose) urls_to_resolve
218
+
(* Resolve all DOIs and URLs using Eio *)
219
+
let new_entries = Eio_main.run @@ fun env ->
220
+
Eio.Switch.run @@ fun sw ->
221
+
(* Create Zotero Translation client with connection pooling *)
222
+
let zt = ZT.create ~sw ~env "http://svr-avsm2-eeg-ce:1969" in
223
+
(* Resolve all DOIs *)
224
+
let new_doi_entries = List.map (resolve_doi zt ~verbose) dois_to_resolve in
225
+
(* Resolve all publisher URLs *)
226
+
let new_url_entries = List.map (resolve_url zt ~verbose) urls_to_resolve in
227
+
new_doi_entries @ new_url_entries
235
228
in
236
-
237
-
let new_doi_entries = Lwt_main.run resolved_doi_entries_lwt in
238
-
let new_url_entries = Lwt_main.run resolved_url_entries_lwt in
239
-
let new_entries = new_doi_entries @ new_url_entries in
240
229
241
230
(* Merge with existing entries, combining source_urls for entries with the same DOI *)
242
231
let all_entries =
+38
-95
stack/bushel/bin/bushel_faces.ml
+38
-95
stack/bushel/bin/bushel_faces.ml
···
1
1
open Cmdliner
2
-
open Lwt.Infix
3
2
open Printf
4
3
5
-
(* Type for person response *)
6
-
type person = {
7
-
id: string;
8
-
name: string;
9
-
thumbnailPath: string option;
10
-
}
11
-
12
-
(* Parse a person from JSON *)
13
-
let parse_person json =
14
-
let open Ezjsonm in
15
-
let id = find json ["id"] |> get_string in
16
-
let name = find json ["name"] |> get_string in
17
-
let thumbnailPath =
18
-
try Some (find json ["thumbnailPath"] |> get_string)
19
-
with _ -> None
20
-
in
21
-
{ id; name; thumbnailPath }
22
-
23
-
(* Parse a list of people from JSON response *)
24
-
let parse_people_response json =
25
-
let open Ezjsonm in
26
-
get_list parse_person json
27
-
28
4
(* Read API key from file *)
29
5
let read_api_key file =
30
6
let ic = open_in file in
···
32
8
close_in ic;
33
9
key
34
10
35
-
(* Search for a person by name *)
36
-
let search_person base_url api_key name =
37
-
let open Cohttp_lwt_unix in
38
-
let headers = Cohttp.Header.init_with "X-Api-Key" api_key in
39
-
let encoded_name = Uri.pct_encode name in
40
-
let url = Printf.sprintf "%s/api/search/person?name=%s" base_url encoded_name in
41
-
42
-
Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->
43
-
if resp.status = `OK then
44
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
45
-
let json = Ezjsonm.from_string body_str in
46
-
Lwt.return (parse_people_response json)
47
-
else
48
-
let status_code = Cohttp.Code.code_of_status resp.status in
49
-
Lwt.fail_with (Printf.sprintf "HTTP error: %d" status_code)
50
-
51
-
(* Download thumbnail for a person *)
52
-
let download_thumbnail base_url api_key person_id output_path =
53
-
let open Cohttp_lwt_unix in
54
-
let headers = Cohttp.Header.init_with "X-Api-Key" api_key in
55
-
let url = Printf.sprintf "%s/api/people/%s/thumbnail" base_url person_id in
56
-
57
-
Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->
58
-
match resp.status with
59
-
| `OK ->
60
-
Cohttp_lwt.Body.to_string body >>= fun img_data ->
61
-
(* Ensure output directory exists *)
62
-
(try
63
-
let dir = Filename.dirname output_path in
64
-
if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;
65
-
Lwt.return_unit
66
-
with _ -> Lwt.return_unit) >>= fun () ->
67
-
Lwt_io.with_file ~mode:Lwt_io.output output_path
68
-
(fun oc -> Lwt_io.write oc img_data) >>= fun () ->
69
-
Lwt.return_ok output_path
70
-
| _ ->
71
-
let status_code = Cohttp.Code.code_of_status resp.status in
72
-
Lwt.return_error (Printf.sprintf "HTTP error: %d" status_code)
73
-
74
11
(* Get face for a single contact *)
75
-
(* TODO:claude *)
76
-
let get_face_for_contact base_url api_key output_dir contact =
12
+
let get_face_for_contact immiche_client ~fs output_dir contact =
77
13
let names = Bushel.Contact.names contact in
78
14
let handle = Bushel.Contact.handle contact in
79
15
let output_path = Filename.concat output_dir (handle ^ ".jpg") in
80
16
81
17
(* Skip if file already exists *)
82
18
if Sys.file_exists output_path then
83
-
Lwt.return (`Skipped (sprintf "Thumbnail for '%s' already exists at %s" (List.hd names) output_path))
19
+
`Skipped (sprintf "Thumbnail for '%s' already exists at %s" (List.hd names) output_path)
84
20
else begin
85
21
printf "Processing contact: %s (handle: %s)\n%!" (List.hd names) handle;
86
22
87
23
(* Try each name in the list until we find a match *)
88
24
let rec try_names = function
89
25
| [] ->
90
-
Lwt.return (`Error (sprintf "No person found with any name for contact '%s'" handle))
26
+
`Error (sprintf "No person found with any name for contact '%s'" handle)
91
27
| name :: rest_names ->
92
28
printf " Trying name: %s\n%!" name;
93
-
search_person base_url api_key name >>= function
29
+
let people = Immiche.search_person immiche_client ~name in
30
+
(match people with
94
31
| [] ->
95
32
printf " No results for '%s', trying next name...\n%!" name;
96
33
try_names rest_names
97
34
| person :: _ ->
98
35
printf " Found match for '%s'\n%!" name;
99
-
download_thumbnail base_url api_key person.id output_path >>= function
100
-
| Ok path ->
101
-
Lwt.return (`Ok (sprintf "Saved thumbnail for '%s' to %s" name path))
102
-
| Error err ->
103
-
Lwt.return (`Error (sprintf "Error for '%s': %s" name err))
36
+
let result = Immiche.download_thumbnail immiche_client
37
+
~fs ~person_id:person.id ~output_path in
38
+
(match result with
39
+
| Ok _ ->
40
+
`Ok (sprintf "Saved thumbnail for '%s' to %s" name output_path)
41
+
| Error (`Msg err) ->
42
+
`Error (sprintf "Error for '%s': %s" name err)))
104
43
in
105
44
try_names names
106
45
end
107
46
108
47
(* Process all contacts or a specific one *)
109
-
let process_contacts base_dir output_dir specific_handle api_key base_url =
48
+
let process_contacts ~sw ~env base_dir output_dir specific_handle api_key base_url =
110
49
printf "Loading Bushel database from %s\n%!" base_dir;
111
50
let db = Bushel.load base_dir in
112
51
let contacts = Bushel.Entry.contacts db in
113
52
printf "Found %d contacts\n%!" (List.length contacts);
114
-
53
+
54
+
(* Create Immiche client for connection pooling *)
55
+
let immiche_client = Immiche.create ~sw ~env ~base_url ~api_key () in
56
+
115
57
(* Ensure output directory exists *)
116
58
if not (Sys.file_exists output_dir) then Unix.mkdir output_dir 0o755;
117
-
59
+
118
60
(* Filter contacts based on specific_handle if provided *)
119
-
let contacts_to_process =
61
+
let contacts_to_process =
120
62
match specific_handle with
121
-
| Some handle ->
63
+
| Some handle ->
122
64
begin match Bushel.Contact.find_by_handle contacts handle with
123
65
| Some contact -> [contact]
124
-
| None ->
66
+
| None ->
125
67
eprintf "No contact found with handle '%s'\n%!" handle;
126
68
[]
127
69
end
128
70
| None -> contacts
129
71
in
130
-
72
+
131
73
(* Process each contact *)
132
-
let results = Lwt_main.run begin
133
-
Lwt_list.map_s
134
-
(fun contact ->
135
-
get_face_for_contact base_url api_key output_dir contact >>= fun result ->
136
-
Lwt.return (Bushel.Contact.handle contact, result))
137
-
contacts_to_process
138
-
end in
139
-
74
+
let results = List.map
75
+
(fun contact ->
76
+
let result = get_face_for_contact immiche_client ~fs:env#fs output_dir contact in
77
+
(Bushel.Contact.handle contact, result))
78
+
contacts_to_process
79
+
in
80
+
140
81
(* Print summary *)
141
82
let ok_count = List.length (List.filter (fun (_, r) -> match r with `Ok _ -> true | _ -> false) results) in
142
83
let error_count = List.length (List.filter (fun (_, r) -> match r with `Error _ -> true | _ -> false) results) in
143
84
let skipped_count = List.length (List.filter (fun (_, r) -> match r with `Skipped _ -> true | _ -> false) results) in
144
-
85
+
145
86
printf "\nSummary:\n";
146
87
printf " Successfully processed: %d\n" ok_count;
147
88
printf " Errors: %d\n" error_count;
148
89
printf " Skipped (already exist): %d\n" skipped_count;
149
-
90
+
150
91
(* Print detailed results *)
151
92
if error_count > 0 then begin
152
93
printf "\nError details:\n";
···
156
97
| _ -> ())
157
98
results;
158
99
end;
159
-
100
+
160
101
if ok_count > 0 || skipped_count > 0 then 0 else 1
161
102
162
103
(* Command line interface *)
···
167
108
const (fun base_dir output_dir handle api_key_file base_url ->
168
109
try
169
110
let api_key = read_api_key api_key_file in
170
-
process_contacts base_dir output_dir handle api_key base_url
171
-
with e ->
111
+
Eio_main.run @@ fun env ->
112
+
Eio.Switch.run @@ fun sw ->
113
+
process_contacts ~sw ~env base_dir output_dir handle api_key base_url
114
+
with e ->
172
115
eprintf "Error: %s\n%!" (Printexc.to_string e);
173
116
1
174
-
) $ Bushel_common.base_dir $ Bushel_common.output_dir ~default:"." $ Bushel_common.handle_opt $
175
-
Bushel_common.api_key_file ~default:".photos-api" $
117
+
) $ Bushel_common.base_dir $ Bushel_common.output_dir ~default:"." $ Bushel_common.handle_opt $
118
+
Bushel_common.api_key_file ~default:".photos-api" $
176
119
Bushel_common.url_term ~default:"https://photos.recoil.org" ~doc:"Base URL of the Immich instance")
177
120
178
121
let cmd =
+187
-189
stack/bushel/bin/bushel_links.ml
+187
-189
stack/bushel/bin/bushel_links.ml
···
1
1
open Cmdliner
2
-
open Lwt.Infix
3
2
4
3
(* Helper function for logging with proper flushing *)
5
4
let log fmt = Fmt.kstr (fun s -> prerr_string s; flush stderr) fmt
6
-
let log_verbose verbose fmt =
7
-
if verbose then Fmt.kstr (fun s -> prerr_string s; flush stderr) fmt
5
+
let log_verbose verbose fmt =
6
+
if verbose then Fmt.kstr (fun s -> prerr_string s; flush stderr) fmt
8
7
else Fmt.kstr (fun _ -> ()) fmt
9
8
10
9
(* Initialize a new links.yml file or ensure it exists *)
···
19
18
0
20
19
21
20
(* Update links.yml from Karakeep *)
22
-
let update_from_karakeep base_url api_key_opt tag links_file download_assets =
21
+
let update_from_karakeep ~sw ~env base_url api_key_opt tag links_file download_assets =
23
22
match api_key_opt with
24
23
| None ->
25
24
prerr_endline "Error: API key is required.";
···
27
26
1
28
27
| Some api_key ->
29
28
let assets_dir = "data/assets" in
30
-
31
-
(* Run the Lwt program *)
32
-
Lwt_main.run (
29
+
30
+
try
33
31
print_endline (Fmt.str "Fetching links from %s with tag '%s'..." base_url tag);
34
-
32
+
35
33
(* Prepare tag filter *)
36
34
let filter_tags = if tag = "" then [] else [tag] in
37
-
38
-
(* Fetch bookmarks from Karakeep with error handling *)
39
-
Lwt.catch
40
-
(fun () ->
41
-
Karakeep.fetch_all_bookmarks ~api_key ~filter_tags base_url >>= fun bookmarks ->
42
-
43
-
print_endline (Fmt.str "Retrieved %d bookmarks from Karakeep" (List.length bookmarks));
44
-
45
-
(* Read existing links if file exists *)
46
-
let existing_links = Bushel.Link.load_links_file links_file in
47
-
48
-
(* Convert bookmarks to bushel links *)
49
-
let new_links = List.map (fun bookmark ->
50
-
Karakeep.to_bushel_link ~base_url bookmark
51
-
) bookmarks in
52
-
53
-
(* Merge with existing links - keep existing dates (karakeep dates may be unreliable) *)
54
-
let merged_links = Bushel.Link.merge_links existing_links new_links in
55
-
56
-
(* Save the updated links file *)
57
-
Bushel.Link.save_links_file links_file merged_links;
58
-
59
-
print_endline (Fmt.str "Updated %s with %d links" links_file (List.length merged_links));
60
-
61
-
(* Download assets if requested *)
62
-
if download_assets then begin
63
-
print_endline "Downloading assets for bookmarks...";
64
-
65
-
(* Ensure the assets directory exists *)
66
-
(try Unix.mkdir assets_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
67
-
68
-
(* Process each bookmark with assets *)
69
-
Lwt_list.iter_s (fun bookmark ->
70
-
(* Extract asset IDs from bookmark *)
71
-
let assets = bookmark.Karakeep.assets in
72
-
73
-
(* Skip if no assets *)
74
-
if assets = [] then
75
-
Lwt.return_unit
76
-
else
77
-
(* Process each asset *)
78
-
Lwt_list.iter_s (fun (asset_id, asset_type) ->
79
-
let asset_dir = Fmt.str "%s/%s" assets_dir asset_id in
80
-
let asset_file = Fmt.str "%s/asset.bin" asset_dir in
81
-
let meta_file = Fmt.str "%s/metadata.json" asset_dir in
82
-
83
-
(* Skip if the asset already exists *)
84
-
if Sys.file_exists asset_file then
85
-
Lwt.return_unit
86
-
else begin
87
-
(* Create the asset directory *)
88
-
(try Unix.mkdir asset_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
89
-
90
-
(* Download the asset *)
91
-
print_endline (Fmt.str "Downloading %s asset %s..." asset_type asset_id);
92
-
Karakeep.fetch_asset ~api_key base_url asset_id >>= fun data ->
93
-
94
-
(* Guess content type based on first bytes *)
95
-
let content_type =
96
-
if String.length data >= 4 && String.sub data 0 4 = "\x89PNG" then
97
-
"image/png"
98
-
else if String.length data >= 3 && String.sub data 0 3 = "\xFF\xD8\xFF" then
99
-
"image/jpeg"
100
-
else if String.length data >= 4 && String.sub data 0 4 = "%PDF" then
101
-
"application/pdf"
102
-
else
103
-
"application/octet-stream"
104
-
in
105
-
106
-
(* Write the asset data *)
107
-
Lwt_io.with_file ~mode:Lwt_io.Output asset_file (fun oc ->
108
-
Lwt_io.write oc data
109
-
) >>= fun () ->
110
-
111
-
(* Write metadata file *)
112
-
let metadata = Fmt.str "{\n \"contentType\": \"%s\",\n \"assetType\": \"%s\"\n}"
113
-
content_type asset_type in
114
-
Lwt_io.with_file ~mode:Lwt_io.Output meta_file (fun oc ->
115
-
Lwt_io.write oc metadata
116
-
)
117
-
end
118
-
) assets
119
-
) bookmarks >>= fun () ->
120
-
121
-
print_endline "Asset download completed.";
122
-
Lwt.return 0
123
-
end else
124
-
Lwt.return 0
125
-
)
126
-
(fun exn ->
127
-
prerr_endline (Fmt.str "Error fetching bookmarks: %s" (Printexc.to_string exn));
128
-
Lwt.return 1
129
-
)
130
-
)
35
+
36
+
(* Fetch bookmarks from Karakeep *)
37
+
let bookmarks = Karakeepe.fetch_all_bookmarks ~sw ~env ~api_key ~filter_tags base_url in
38
+
39
+
print_endline (Fmt.str "Retrieved %d bookmarks from Karakeep" (List.length bookmarks));
40
+
41
+
(* Read existing links if file exists *)
42
+
let existing_links = Bushel.Link.load_links_file links_file in
43
+
44
+
(* Convert bookmarks to bushel links *)
45
+
let new_links = List.map (fun bookmark ->
46
+
Karakeepe.to_bushel_link ~base_url bookmark
47
+
) bookmarks in
48
+
49
+
(* Merge with existing links - keep existing dates (karakeep dates may be unreliable) *)
50
+
let merged_links = Bushel.Link.merge_links existing_links new_links in
51
+
52
+
(* Save the updated links file *)
53
+
Bushel.Link.save_links_file links_file merged_links;
54
+
55
+
print_endline (Fmt.str "Updated %s with %d links" links_file (List.length merged_links));
56
+
57
+
(* Download assets if requested *)
58
+
if download_assets then begin
59
+
print_endline "Downloading assets for bookmarks...";
60
+
61
+
(* Ensure the assets directory exists *)
62
+
(try Unix.mkdir assets_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
63
+
64
+
(* Process each bookmark with assets *)
65
+
List.iter (fun bookmark ->
66
+
(* Extract asset IDs from bookmark *)
67
+
let assets = bookmark.Karakeepe.assets in
68
+
69
+
(* Skip if no assets *)
70
+
if assets <> [] then
71
+
(* Process each asset *)
72
+
List.iter (fun (asset_id, asset_type) ->
73
+
let asset_dir = Fmt.str "%s/%s" assets_dir asset_id in
74
+
let asset_file = Fmt.str "%s/asset.bin" asset_dir in
75
+
let meta_file = Fmt.str "%s/metadata.json" asset_dir in
76
+
77
+
(* Skip if the asset already exists *)
78
+
if not (Sys.file_exists asset_file) then begin
79
+
(* Create the asset directory *)
80
+
(try Unix.mkdir asset_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
81
+
82
+
(* Download the asset *)
83
+
print_endline (Fmt.str "Downloading %s asset %s..." asset_type asset_id);
84
+
let data = Karakeepe.fetch_asset ~sw ~env ~api_key base_url asset_id in
85
+
86
+
(* Guess content type based on first bytes *)
87
+
let content_type =
88
+
if String.length data >= 4 && String.sub data 0 4 = "\x89PNG" then
89
+
"image/png"
90
+
else if String.length data >= 3 && String.sub data 0 3 = "\xFF\xD8\xFF" then
91
+
"image/jpeg"
92
+
else if String.length data >= 4 && String.sub data 0 4 = "%PDF" then
93
+
"application/pdf"
94
+
else
95
+
"application/octet-stream"
96
+
in
97
+
98
+
(* Write the asset data *)
99
+
let oc = open_out_bin asset_file in
100
+
output_string oc data;
101
+
close_out oc;
102
+
103
+
(* Write metadata file *)
104
+
let metadata = Fmt.str "{\n \"contentType\": \"%s\",\n \"assetType\": \"%s\"\n}"
105
+
content_type asset_type in
106
+
let oc = open_out meta_file in
107
+
output_string oc metadata;
108
+
close_out oc
109
+
end
110
+
) assets
111
+
) bookmarks;
112
+
113
+
print_endline "Asset download completed.";
114
+
0
115
+
end else
116
+
0
117
+
with exn ->
118
+
prerr_endline (Fmt.str "Error fetching bookmarks: %s" (Printexc.to_string exn));
119
+
1
131
120
132
121
(* Extract outgoing links from Bushel entries *)
133
122
let update_from_bushel bushel_dir links_file include_domains exclude_domains =
···
297
286
create_batches_aux links []
298
287
299
288
(* Helper function to upload a single link to Karakeep *)
300
-
let upload_single_link api_key base_url tag verbose updated_links link =
289
+
let upload_single_link ~sw ~env api_key base_url tag verbose updated_links link =
301
290
let url = link.Bushel.Link.url in
302
-
let title =
303
-
if link.Bushel.Link.description <> "" then
304
-
Some link.Bushel.Link.description
305
-
else None
291
+
let title =
292
+
if link.Bushel.Link.description <> "" then
293
+
Some link.Bushel.Link.description
294
+
else None
306
295
in
307
296
let tags = prepare_tags_for_link tag link in
308
-
297
+
309
298
if verbose then begin
310
299
log " Uploading: %s\n" url;
311
-
if tags <> [] then
300
+
if tags <> [] then
312
301
log " Tags: %s\n" (String.concat ", " tags);
313
-
if title <> None then
302
+
if title <> None then
314
303
log " Title: %s\n" (Option.get title);
315
304
end else begin
316
305
log "Uploading: %s\n" url;
317
306
end;
318
-
307
+
319
308
(* Create the bookmark with tags *)
320
-
Lwt.catch
321
-
(fun () ->
322
-
Karakeep.create_bookmark
323
-
~api_key
324
-
~url
325
-
?title
326
-
~tags
327
-
base_url
328
-
>>= fun bookmark ->
329
-
330
-
(* Create updated link with karakeep data *)
331
-
let updated_link = {
332
-
link with
333
-
Bushel.Link.karakeep =
334
-
Some {
335
-
Bushel.Link.remote_url = base_url;
336
-
id = bookmark.id;
337
-
tags = bookmark.tags;
338
-
metadata = []; (* Will be populated on next sync *)
339
-
}
340
-
} in
341
-
updated_links := updated_link :: !updated_links;
342
-
343
-
if verbose then
344
-
log " ✓ Added to Karakeep with ID: %s\n" bookmark.id
345
-
else
346
-
log " - Added to Karakeep with ID: %s\n" bookmark.id;
347
-
Lwt.return 1 (* Success *)
348
-
)
349
-
(fun exn ->
350
-
if verbose then
351
-
log " ✗ Error uploading %s: %s\n" url (Printexc.to_string exn)
352
-
else
353
-
log " - Error uploading %s: %s\n" url (Printexc.to_string exn);
354
-
Lwt.return 0 (* Failure *)
355
-
)
309
+
try
310
+
let bookmark = Karakeepe.create_bookmark
311
+
~sw ~env
312
+
~api_key
313
+
~url
314
+
?title
315
+
~tags
316
+
base_url
317
+
in
318
+
319
+
(* Create updated link with karakeep data *)
320
+
let updated_link = {
321
+
link with
322
+
Bushel.Link.karakeep =
323
+
Some {
324
+
Bushel.Link.remote_url = base_url;
325
+
id = bookmark.id;
326
+
tags = bookmark.tags;
327
+
metadata = []; (* Will be populated on next sync *)
328
+
}
329
+
} in
330
+
updated_links := updated_link :: !updated_links;
331
+
332
+
if verbose then
333
+
log " ✓ Added to Karakeep with ID: %s\n" bookmark.id
334
+
else
335
+
log " - Added to Karakeep with ID: %s\n" bookmark.id;
336
+
1 (* Success *)
337
+
with exn ->
338
+
if verbose then
339
+
log " ✗ Error uploading %s: %s\n" url (Printexc.to_string exn)
340
+
else
341
+
log " - Error uploading %s: %s\n" url (Printexc.to_string exn);
342
+
0 (* Failure *)
356
343
357
344
(* Helper function to process a batch of links *)
358
-
let process_batch api_key base_url tag verbose updated_links batch_num total_batches batch =
359
-
log_verbose verbose "\nProcessing batch %d/%d (%d links)...\n"
345
+
let process_batch ~sw ~env api_key base_url tag verbose updated_links batch_num total_batches batch =
346
+
log_verbose verbose "\nProcessing batch %d/%d (%d links)...\n"
360
347
(batch_num + 1) total_batches (List.length batch);
361
-
362
-
(* Process links in this batch concurrently *)
363
-
Lwt_list.map_p (upload_single_link api_key base_url tag verbose updated_links) batch
348
+
349
+
(* Process links in this batch in parallel *)
350
+
let results = ref [] in
351
+
Eio.Fiber.all (List.map (fun link ->
352
+
fun () ->
353
+
let count = upload_single_link ~sw ~env api_key base_url tag verbose updated_links link in
354
+
results := count :: !results
355
+
) batch);
356
+
List.rev !results
364
357
365
358
(* Helper function to update links file with new karakeep data *)
366
359
let update_links_file links_file original_links updated_links =
···
384
377
end
385
378
386
379
(* Upload links to Karakeep that don't already have karakeep data *)
387
-
let upload_to_karakeep base_url api_key_opt links_file tag max_concurrent delay_seconds limit verbose =
380
+
let upload_to_karakeep ~sw ~env base_url api_key_opt links_file tag max_concurrent delay_seconds limit verbose =
388
381
match api_key_opt with
389
382
| None ->
390
383
log "Error: API key is required.\n";
···
395
388
log_verbose verbose "Loading links from %s...\n" links_file;
396
389
let links = Bushel.Link.load_links_file links_file in
397
390
log_verbose verbose "Loaded %d total links\n" (List.length links);
398
-
391
+
399
392
(* Filter links that don't have karakeep data for this remote *)
400
393
log_verbose verbose "Filtering links that don't have karakeep data for %s...\n" base_url;
401
394
let filtered_links = filter_links_without_karakeep base_url links in
402
395
log_verbose verbose "Found %d links without karakeep data\n" (List.length filtered_links);
403
-
396
+
404
397
(* Apply limit if specified *)
405
398
let links_to_upload = apply_limit_to_links limit filtered_links in
406
-
399
+
407
400
if links_to_upload = [] then begin
408
401
log "No links to upload to %s (all links already have karakeep data)\n" base_url;
409
402
0
410
403
end else begin
411
404
log "Found %d links to upload to %s\n" (List.length links_to_upload) base_url;
412
-
405
+
413
406
(* Split links into batches for parallel processing *)
414
407
let batches = create_batches max_concurrent links_to_upload in
415
-
log_verbose verbose "Processing in %d batches of up to %d links each...\n"
408
+
log_verbose verbose "Processing in %d batches of up to %d links each...\n"
416
409
(List.length batches) max_concurrent;
417
410
log_verbose verbose "Delay between batches: %.1f seconds\n" delay_seconds;
418
-
411
+
419
412
(* Process batches and accumulate updated links *)
420
413
let updated_links = ref [] in
421
-
422
-
let result = Lwt_main.run (
423
-
Lwt.catch
424
-
(fun () ->
425
-
Lwt_list.fold_left_s (fun (total_count, batch_num) batch ->
426
-
process_batch api_key base_url tag verbose updated_links
427
-
batch_num (List.length batches) batch >>= fun results ->
428
-
414
+
415
+
let result = try
416
+
let rec process_batches total_count batch_num = function
417
+
| [] -> total_count
418
+
| batch :: rest ->
419
+
let results = process_batch ~sw ~env api_key base_url tag verbose updated_links
420
+
batch_num (List.length batches) batch in
421
+
429
422
(* Count successes in this batch *)
430
423
let batch_successes = List.fold_left (+) 0 results in
431
424
let new_total = total_count + batch_successes in
432
-
433
-
log_verbose verbose " Batch %d complete: %d/%d successful (Total: %d/%d)\n"
425
+
426
+
log_verbose verbose " Batch %d complete: %d/%d successful (Total: %d/%d)\n"
434
427
(batch_num + 1) batch_successes (List.length batch) new_total (new_total + (List.length links_to_upload - new_total));
435
-
428
+
436
429
(* Add a delay before processing the next batch *)
437
-
if batch_num + 1 < List.length batches then begin
430
+
if rest <> [] then begin
438
431
log_verbose verbose " Waiting %.1f seconds before next batch...\n" delay_seconds;
439
-
Lwt_unix.sleep delay_seconds >>= fun () ->
440
-
Lwt.return (new_total, batch_num + 1)
441
-
end else
442
-
Lwt.return (new_total, batch_num + 1)
443
-
) (0, 0) batches >>= fun (final_count, _) ->
444
-
Lwt.return final_count
445
-
)
446
-
(fun exn ->
447
-
log "Error during upload operation: %s\n" (Printexc.to_string exn);
448
-
Lwt.return 0
449
-
)
450
-
) in
451
-
432
+
Eio.Time.sleep (Eio.Stdenv.clock env) delay_seconds;
433
+
end;
434
+
process_batches new_total (batch_num + 1) rest
435
+
in
436
+
process_batches 0 0 batches
437
+
with exn ->
438
+
log "Error during upload operation: %s\n" (Printexc.to_string exn);
439
+
0
440
+
in
441
+
452
442
(* Update the links file with the new karakeep_ids *)
453
443
update_links_file links_file links updated_links;
454
-
455
-
log "Upload complete. %d/%d links uploaded successfully.\n"
444
+
445
+
log "Upload complete. %d/%d links uploaded successfully.\n"
456
446
result (List.length links_to_upload);
457
-
447
+
458
448
0
459
449
end
460
450
···
527
517
let karakeep_cmd =
528
518
let doc = "Update links.yml with links from Karakeep" in
529
519
let info = Cmd.info "karakeep" ~doc in
530
-
Cmd.v info Term.(const update_from_karakeep $ base_url_arg $ api_key_arg $ tag_arg $ links_file_arg $ download_assets_arg)
520
+
Cmd.v info Term.(const (fun base_url api_key_opt tag links_file download_assets ->
521
+
Eio_main.run @@ fun env ->
522
+
Eio.Switch.run @@ fun sw ->
523
+
update_from_karakeep ~sw ~env base_url api_key_opt tag links_file download_assets)
524
+
$ base_url_arg $ api_key_arg $ tag_arg $ links_file_arg $ download_assets_arg)
531
525
532
526
let bushel_cmd =
533
527
let doc = "Update links.yml with outgoing links from Bushel entries" in
···
537
531
let upload_cmd =
538
532
let doc = "Upload links without karakeep data to Karakeep" in
539
533
let info = Cmd.info "upload" ~doc in
540
-
Cmd.v info Term.(const upload_to_karakeep $ base_url_arg $ api_key_arg $ links_file_arg $ tag_arg $ concurrent_arg $ delay_arg $ limit_arg $ verbose_arg)
534
+
Cmd.v info Term.(const (fun base_url api_key_opt links_file tag max_concurrent delay_seconds limit verbose ->
535
+
Eio_main.run @@ fun env ->
536
+
Eio.Switch.run @@ fun sw ->
537
+
upload_to_karakeep ~sw ~env base_url api_key_opt links_file tag max_concurrent delay_seconds limit verbose)
538
+
$ base_url_arg $ api_key_arg $ links_file_arg $ tag_arg $ concurrent_arg $ delay_arg $ limit_arg $ verbose_arg)
541
539
542
540
(* Export the term and cmd for use in main bushel.ml *)
543
541
let cmd =
+12
-10
stack/bushel/bin/bushel_paper.ml
+12
-10
stack/bushel/bin/bushel_paper.ml
···
1
1
module ZT = Zotero_translation
2
-
open Lwt.Infix
3
2
open Printf
4
3
module J = Ezjsonm
5
4
open Cmdliner
···
18
17
J.update j ["author"] (Some (`A a))
19
18
20
19
let of_doi zt ~base_dir ~slug ~version doi =
21
-
ZT.json_of_doi zt ~slug doi >>= fun j ->
20
+
let j = ZT.json_of_doi zt ~slug doi in
22
21
let papers_dir = Printf.sprintf "%s/papers/%s" base_dir slug in
23
22
(* Ensure papers directory exists *)
24
23
(try Unix.mkdir papers_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
25
-
24
+
26
25
(* Extract abstract from JSON data *)
27
26
let abstract = try
28
27
let keys = Ezjsonm.get_dict (j :> Ezjsonm.value) in
···
30
29
| Some abstract_json -> Some (Ezjsonm.get_string abstract_json)
31
30
| None -> None
32
31
with _ -> None in
33
-
32
+
34
33
(* Remove abstract from frontmatter - it goes in body *)
35
34
let keys = Ezjsonm.get_dict (j :> Ezjsonm.value) in
36
35
let filtered_keys = List.filter (fun (k, _) -> k <> "abstract") keys in
37
36
let json_without_abstract = `O filtered_keys in
38
-
37
+
39
38
(* Use library function to generate YAML with abstract in body *)
40
39
let content = Bushel.Paper.to_yaml ?abstract ~ver:version json_without_abstract in
41
-
40
+
42
41
let filename = Printf.sprintf "%s.md" version in
43
42
let filepath = Filename.concat papers_dir filename in
44
43
let oc = open_out filepath in
45
44
output_string oc content;
46
45
close_out oc;
47
-
Printf.printf "Created paper file: %s\n" filepath;
48
-
Lwt.return ()
46
+
Printf.printf "Created paper file: %s\n" filepath
49
47
50
48
let slug_arg =
51
49
let doc = "Slug for the entry." in
···
62
60
(* Export the term for use in main bushel.ml *)
63
61
let term =
64
62
Term.(const (fun base slug version doi ->
65
-
let zt = ZT.v "http://svr-avsm2-eeg-ce:1969" in
66
-
Lwt_main.run @@ of_doi zt ~base_dir:base ~slug ~version doi; 0
63
+
Eio_main.run @@ fun env ->
64
+
Eio.Switch.run @@ fun sw ->
65
+
(* Create Zotero Translation client with connection pooling *)
66
+
let zt = ZT.create ~sw ~env "http://svr-avsm2-eeg-ce:1969" in
67
+
of_doi zt ~base_dir:base ~slug ~version doi;
68
+
0
67
69
) $ Bushel_common.base_dir $ slug_arg $ version_arg $ doi_arg)
68
70
69
71
let cmd =
+20
-22
stack/bushel/bin/bushel_search.ml
+20
-22
stack/bushel/bin/bushel_search.ml
···
1
1
open Cmdliner
2
-
open Lwt.Syntax
3
2
4
3
(** TODO:claude Bushel search command for integration with main CLI *)
5
4
···
42
41
Printf.printf "Query: \"%s\"\n" query_text;
43
42
Printf.printf "Limit: %d, Offset: %d\n" limit offset;
44
43
Printf.printf "\n";
45
-
46
-
Lwt_main.run (
47
-
Lwt.catch (fun () ->
48
-
let* result = Bushel.Typesense.multisearch config query_text ~limit:50 () in
49
-
match result with
50
-
| Ok multisearch_resp ->
51
-
let combined_response = Bushel.Typesense.combine_multisearch_results multisearch_resp ~limit ~offset () in
52
-
Printf.printf "Found %d results (%.2fms)\n\n" combined_response.total combined_response.query_time;
53
-
54
-
List.iteri (fun i (hit : Bushel.Typesense.search_result) ->
55
-
Printf.printf "%d. %s (score: %.2f)\n" (i + 1) (Bushel.Typesense.pp_search_result_oneline hit) hit.Bushel.Typesense.score
56
-
) combined_response.hits;
57
-
Lwt.return_unit
58
-
| Error err ->
59
-
Format.eprintf "Search error: %a\n" Bushel.Typesense.pp_error err;
60
-
exit 1
61
-
) (fun exn ->
62
-
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
44
+
45
+
Eio_main.run @@ fun env ->
46
+
Eio.Switch.run @@ fun sw ->
47
+
(try
48
+
let result = Bushel.Typesense.multisearch ~sw ~env config query_text ~limit:50 () in
49
+
match result with
50
+
| Ok multisearch_resp ->
51
+
let combined_response = Bushel.Typesense.combine_multisearch_results multisearch_resp ~limit ~offset () in
52
+
Printf.printf "Found %d results (%.2fms)\n\n" combined_response.total combined_response.query_time;
53
+
54
+
List.iteri (fun i (hit : Bushel.Typesense.search_result) ->
55
+
Printf.printf "%d. %s (score: %.2f)\n" (i + 1) (Bushel.Typesense.pp_search_result_oneline hit) hit.Bushel.Typesense.score
56
+
) combined_response.hits;
57
+
0
58
+
| Error err ->
59
+
Format.eprintf "Search error: %a\n" Bushel.Typesense.pp_error err;
63
60
exit 1
64
-
)
65
-
);
66
-
0
61
+
with exn ->
62
+
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
63
+
exit 1
64
+
)
67
65
68
66
(** TODO:claude Command line term *)
69
67
let term = Term.(const search $ endpoint $ api_key $ query_text $ limit $ offset)
+53
-57
stack/bushel/bin/bushel_typesense.ml
+53
-57
stack/bushel/bin/bushel_typesense.ml
···
1
1
open Cmdliner
2
-
open Lwt.Syntax
3
2
4
3
(** TODO:claude Bushel Typesense binary with upload and query functionality *)
5
4
···
38
37
39
38
Printf.printf "Uploading bushel data to Typesense at %s\n" endpoint;
40
39
41
-
Lwt_main.run (
42
-
Lwt.catch (fun () ->
43
-
Bushel.Typesense.upload_all config entries
44
-
) (fun exn ->
45
-
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
46
-
exit 1
47
-
)
40
+
Eio_main.run @@ fun env ->
41
+
Eio.Switch.run @@ fun sw ->
42
+
(try
43
+
Bushel.Typesense.upload_all ~sw ~env config entries
44
+
with exn ->
45
+
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
46
+
exit 1
48
47
)
49
48
50
49
···
67
66
if collection <> "" then Printf.printf "Collection: %s\n" collection;
68
67
Printf.printf "Limit: %d, Offset: %d\n" limit offset;
69
68
Printf.printf "\n";
70
-
71
-
Lwt_main.run (
72
-
Lwt.catch (fun () ->
73
-
let search_fn = if collection = "" then
74
-
Bushel.Typesense.search_all config query_text ~limit ~offset
75
-
else
76
-
Bushel.Typesense.search_collection config collection query_text ~limit ~offset
77
-
in
78
-
let* result = search_fn () in
79
-
match result with
80
-
| Ok response ->
81
-
Printf.printf "Found %d results (%.2fms)\n\n" response.total response.query_time;
82
-
List.iteri (fun i (hit : Bushel.Typesense.search_result) ->
83
-
Printf.printf "%d. [%s] %s (score: %.2f)\n" (i + 1) hit.collection hit.title hit.score;
84
-
if hit.content <> "" then Printf.printf " %s\n" hit.content;
85
-
if hit.highlights <> [] then (
86
-
Printf.printf " Highlights:\n";
87
-
List.iter (fun (field, snippets) ->
88
-
List.iter (fun snippet ->
89
-
Printf.printf " %s: %s\n" field snippet
90
-
) snippets
91
-
) hit.highlights
92
-
);
93
-
Printf.printf "\n"
94
-
) response.hits;
95
-
Lwt.return_unit
96
-
| Error err ->
97
-
Format.eprintf "Search error: %a\n" Bushel.Typesense.pp_error err;
98
-
exit 1
99
-
) (fun exn ->
100
-
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
69
+
70
+
Eio_main.run @@ fun env ->
71
+
Eio.Switch.run @@ fun sw ->
72
+
(try
73
+
let result = if collection = "" then
74
+
Bushel.Typesense.search_all ~sw ~env config query_text ~limit ~offset ()
75
+
else
76
+
Bushel.Typesense.search_collection ~sw ~env config collection query_text ~limit ~offset ()
77
+
in
78
+
match result with
79
+
| Ok response ->
80
+
Printf.printf "Found %d results (%.2fms)\n\n" response.total response.query_time;
81
+
List.iteri (fun i (hit : Bushel.Typesense.search_result) ->
82
+
Printf.printf "%d. [%s] %s (score: %.2f)\n" (i + 1) hit.collection hit.title hit.score;
83
+
if hit.content <> "" then Printf.printf " %s\n" hit.content;
84
+
if hit.highlights <> [] then (
85
+
Printf.printf " Highlights:\n";
86
+
List.iter (fun (field, snippets) ->
87
+
List.iter (fun snippet ->
88
+
Printf.printf " %s: %s\n" field snippet
89
+
) snippets
90
+
) hit.highlights
91
+
);
92
+
Printf.printf "\n"
93
+
) response.hits
94
+
| Error err ->
95
+
Format.eprintf "Search error: %a\n" Bushel.Typesense.pp_error err;
101
96
exit 1
102
-
)
97
+
with exn ->
98
+
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
99
+
exit 1
103
100
)
104
101
105
102
(** TODO:claude List collections function *)
···
117
114
);
118
115
119
116
Printf.printf "Listing collections at %s\n\n" config.endpoint;
120
-
121
-
Lwt_main.run (
122
-
Lwt.catch (fun () ->
123
-
let* result = Bushel.Typesense.list_collections config in
124
-
match result with
125
-
| Ok collections ->
126
-
Printf.printf "Collections:\n";
127
-
List.iter (fun (name, count) ->
128
-
Printf.printf " %s (%d documents)\n" name count
129
-
) collections;
130
-
Lwt.return_unit
131
-
| Error err ->
132
-
Format.eprintf "List error: %a\n" Bushel.Typesense.pp_error err;
133
-
exit 1
134
-
) (fun exn ->
135
-
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
117
+
118
+
Eio_main.run @@ fun env ->
119
+
Eio.Switch.run @@ fun sw ->
120
+
(try
121
+
let result = Bushel.Typesense.list_collections ~sw ~env config in
122
+
match result with
123
+
| Ok collections ->
124
+
Printf.printf "Collections:\n";
125
+
List.iter (fun (name, count) ->
126
+
Printf.printf " %s (%d documents)\n" name count
127
+
) collections
128
+
| Error err ->
129
+
Format.eprintf "List error: %a\n" Bushel.Typesense.pp_error err;
136
130
exit 1
137
-
)
131
+
with exn ->
132
+
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
133
+
exit 1
138
134
)
139
135
140
136
(** TODO:claude Command line arguments for query *)
+43
-55
stack/bushel/bin/bushel_video.ml
+43
-55
stack/bushel/bin/bushel_video.ml
···
1
1
[@@@warning "-26-27-32"]
2
2
3
-
open Lwt.Infix
4
3
open Cmdliner
5
4
6
5
let setup_log style_renderer level =
···
9
8
Logs.set_reporter (Logs_fmt.reporter ());
10
9
()
11
10
12
-
let process_videos output_dir overwrite base_url channel fetch_thumbs thumbs_dir =
13
-
Peertube.fetch_all_channel_videos base_url channel >>= fun all_videos ->
11
+
let process_videos ~sw ~env output_dir overwrite base_url channel fetch_thumbs thumbs_dir =
12
+
let all_videos = Peertubee.fetch_all_channel_videos ~sw ~env base_url channel in
14
13
Logs.info (fun f -> f "Total videos: %d" (List.length all_videos));
15
14
16
15
(* Create thumbnails directory if needed *)
···
18
17
Unix.mkdir thumbs_dir 0o755);
19
18
20
19
(* Process each video, fetching full details for complete descriptions *)
21
-
Lwt_list.map_s (fun video ->
20
+
let vids = List.map (fun video ->
22
21
(* Fetch complete video details to get full description *)
23
-
Peertube.fetch_video_details base_url video.Peertube.uuid >>= fun full_video ->
22
+
let full_video = Peertubee.fetch_video_details ~sw ~env base_url video.Peertubee.uuid in
24
23
let (description, published_date, title, url, uuid, slug) =
25
-
Peertube.to_bushel_video full_video
24
+
Peertubee.to_bushel_video full_video
26
25
in
27
26
Logs.info (fun f -> f "Title: %s, URL: %s" title url);
28
27
29
28
(* Download thumbnail if requested *)
30
29
(if fetch_thumbs then
31
30
let thumb_path = Filename.concat thumbs_dir (uuid ^ ".jpg") in
32
-
Peertube.download_thumbnail base_url full_video thumb_path >>= fun result ->
31
+
let result = Peertubee.download_thumbnail ~sw ~env base_url full_video thumb_path in
33
32
match result with
34
33
| Ok () ->
35
-
Logs.info (fun f -> f "Downloaded thumbnail for %s to %s" title thumb_path);
36
-
Lwt.return_unit
34
+
Logs.info (fun f -> f "Downloaded thumbnail for %s to %s" title thumb_path)
37
35
| Error (`Msg e) ->
38
-
Logs.warn (fun f -> f "Failed to download thumbnail for %s: %s" title e);
39
-
Lwt.return_unit
40
-
else
41
-
Lwt.return_unit) >>= fun () ->
36
+
Logs.warn (fun f -> f "Failed to download thumbnail for %s: %s" title e)
37
+
);
38
+
39
+
{Bushel.Video.description; published_date; title; url; uuid; slug;
40
+
talk=false; paper=None; project=None; tags=full_video.tags}
41
+
) all_videos in
42
42
43
-
Lwt.return {Bushel.Video.description; published_date; title; url; uuid; slug;
44
-
talk=false; paper=None; project=None; tags=full_video.tags}
45
-
) all_videos >>= fun vids ->
46
-
47
43
(* Write video files *)
48
-
Lwt_list.iter_s (fun video ->
44
+
List.iter (fun video ->
49
45
let file_path = Filename.concat output_dir (video.Bushel.Video.uuid ^ ".md") in
50
46
let file_exists = Sys.file_exists file_path in
51
-
47
+
52
48
if file_exists then
53
49
try
54
50
(* If file exists, load it to preserve specific fields *)
···
61
57
project = existing_video.project; (* Preserve project field *)
62
58
talk = existing_video.talk; (* Preserve talk field *)
63
59
} in
64
-
60
+
65
61
(* Write the merged video data *)
66
62
if overwrite then
67
63
match Bushel.Video.to_file output_dir merged_video with
68
-
| Ok () ->
69
-
Logs.info (fun f -> f "Updated video %s with preserved fields in %s"
70
-
merged_video.Bushel.Video.title file_path);
71
-
Lwt.return_unit
72
-
| Error (`Msg e) ->
73
-
Logs.err (fun f -> f "Failed to update video %s: %s"
74
-
merged_video.Bushel.Video.title e);
75
-
Lwt.return_unit
76
-
else begin
77
-
Logs.info (fun f -> f "Skipping existing video %s (use --overwrite to replace)"
78
-
video.Bushel.Video.title);
79
-
Lwt.return_unit
80
-
end
64
+
| Ok () ->
65
+
Logs.info (fun f -> f "Updated video %s with preserved fields in %s"
66
+
merged_video.Bushel.Video.title file_path)
67
+
| Error (`Msg e) ->
68
+
Logs.err (fun f -> f "Failed to update video %s: %s"
69
+
merged_video.Bushel.Video.title e)
70
+
else
71
+
Logs.info (fun f -> f "Skipping existing video %s (use --overwrite to replace)"
72
+
video.Bushel.Video.title)
81
73
with _ ->
82
74
(* If reading existing file fails, proceed with new data *)
83
75
if overwrite then
84
76
match Bushel.Video.to_file output_dir video with
85
-
| Ok () ->
86
-
Logs.info (fun f -> f "Wrote video %s to %s (existing file could not be read)"
87
-
video.Bushel.Video.title file_path);
88
-
Lwt.return_unit
89
-
| Error (`Msg e) ->
90
-
Logs.err (fun f -> f "Failed to write video %s: %s"
91
-
video.Bushel.Video.title e);
92
-
Lwt.return_unit
93
-
else begin
94
-
Logs.info (fun f -> f "Skipping existing video %s (use --overwrite to replace)"
95
-
video.Bushel.Video.title);
96
-
Lwt.return_unit
97
-
end
77
+
| Ok () ->
78
+
Logs.info (fun f -> f "Wrote video %s to %s (existing file could not be read)"
79
+
video.Bushel.Video.title file_path)
80
+
| Error (`Msg e) ->
81
+
Logs.err (fun f -> f "Failed to write video %s: %s"
82
+
video.Bushel.Video.title e)
83
+
else
84
+
Logs.info (fun f -> f "Skipping existing video %s (use --overwrite to replace)"
85
+
video.Bushel.Video.title)
98
86
else
99
87
(* If file doesn't exist, just write new data *)
100
88
match Bushel.Video.to_file output_dir video with
101
-
| Ok () ->
102
-
Logs.info (fun f -> f "Wrote new video %s to %s"
103
-
video.Bushel.Video.title file_path);
104
-
Lwt.return_unit
105
-
| Error (`Msg e) ->
106
-
Logs.err (fun f -> f "Failed to write video %s: %s"
107
-
video.Bushel.Video.title e);
108
-
Lwt.return_unit
89
+
| Ok () ->
90
+
Logs.info (fun f -> f "Wrote new video %s to %s"
91
+
video.Bushel.Video.title file_path)
92
+
| Error (`Msg e) ->
93
+
Logs.err (fun f -> f "Failed to write video %s: %s"
94
+
video.Bushel.Video.title e)
109
95
) vids
110
96
111
97
(* Command line arguments are now imported from Bushel_common *)
···
121
107
Arg.(value & opt string "images/videos" & info ["thumbs-dir"] ~docv:"DIR" ~doc)
122
108
in
123
109
Term.(const (fun output_dir overwrite base_url channel fetch_thumbs thumbs_dir () ->
124
-
Lwt_main.run (process_videos output_dir overwrite base_url channel fetch_thumbs thumbs_dir); 0)
110
+
Eio_main.run @@ fun env ->
111
+
Eio.Switch.run @@ fun sw ->
112
+
process_videos ~sw ~env output_dir overwrite base_url channel fetch_thumbs thumbs_dir; 0)
125
113
$ Bushel_common.output_dir ~default:"." $
126
114
Bushel_common.overwrite $
127
115
Bushel_common.url_term ~default:"https://crank.recoil.org" ~doc:"PeerTube base URL" $
+12
-15
stack/bushel/bin/bushel_video_thumbs.ml
+12
-15
stack/bushel/bin/bushel_video_thumbs.ml
···
1
1
[@@@warning "-26-27-32"]
2
2
3
-
open Lwt.Infix
4
3
open Cmdliner
5
4
6
5
let setup_log style_renderer level =
···
9
8
Logs.set_reporter (Logs_fmt.reporter ());
10
9
()
11
10
12
-
let process_video_thumbs videos_dir thumbs_dir base_url =
11
+
let process_video_thumbs ~sw ~env videos_dir thumbs_dir base_url =
13
12
(* Ensure thumbnail directory exists *)
14
13
(if not (Sys.file_exists thumbs_dir) then
15
14
Unix.mkdir thumbs_dir 0o755);
···
24
23
Logs.info (fun f -> f "Found %d video files to process" (List.length video_files));
25
24
26
25
(* Process each video file *)
27
-
Lwt_list.iter_s (fun video_file ->
26
+
List.iter (fun video_file ->
28
27
try
29
28
(* Load existing video *)
30
29
let video = Bushel.Video.of_md video_file in
···
33
32
Logs.info (fun f -> f "Processing video: %s (UUID: %s)" video.title uuid);
34
33
35
34
(* Fetch video details from PeerTube to get thumbnail info *)
36
-
Peertube.fetch_video_details base_url uuid >>= fun peertube_video ->
35
+
let peertube_video = Peertubee.fetch_video_details ~sw ~env base_url uuid in
37
36
38
37
(* Download thumbnail *)
39
38
let thumb_path = Filename.concat thumbs_dir (uuid ^ ".jpg") in
40
-
Peertube.download_thumbnail base_url peertube_video thumb_path >>= fun result ->
39
+
let result = Peertubee.download_thumbnail ~sw ~env base_url peertube_video thumb_path in
41
40
42
41
match result with
43
42
| Ok () ->
44
43
Logs.info (fun f -> f "Downloaded thumbnail for %s to %s" video.title thumb_path);
45
44
46
45
(* Update video file with thumbnail_url field *)
47
-
(match Peertube.thumbnail_url base_url peertube_video with
46
+
(match Peertubee.thumbnail_url base_url peertube_video with
48
47
| Some url ->
49
-
Logs.info (fun f -> f "Thumbnail URL: %s" url);
50
-
Lwt.return_unit
48
+
Logs.info (fun f -> f "Thumbnail URL: %s" url)
51
49
| None ->
52
-
Logs.warn (fun f -> f "No thumbnail URL for video %s" video.title);
53
-
Lwt.return_unit)
50
+
Logs.warn (fun f -> f "No thumbnail URL for video %s" video.title))
54
51
| Error (`Msg e) ->
55
-
Logs.err (fun f -> f "Failed to download thumbnail for %s: %s" video.title e);
56
-
Lwt.return_unit
52
+
Logs.err (fun f -> f "Failed to download thumbnail for %s: %s" video.title e)
57
53
with exn ->
58
-
Logs.err (fun f -> f "Error processing %s: %s" video_file (Printexc.to_string exn));
59
-
Lwt.return_unit
54
+
Logs.err (fun f -> f "Error processing %s: %s" video_file (Printexc.to_string exn))
60
55
) video_files
61
56
62
57
let term =
···
69
64
Arg.(value & opt string "images/videos" & info ["thumbs-dir"; "t"] ~docv:"DIR" ~doc)
70
65
in
71
66
Term.(const (fun videos_dir thumbs_dir base_url () ->
72
-
Lwt_main.run (process_video_thumbs videos_dir thumbs_dir base_url); 0)
67
+
Eio_main.run @@ fun env ->
68
+
Eio.Switch.run @@ fun sw ->
69
+
process_video_thumbs ~sw ~env videos_dir thumbs_dir base_url; 0)
73
70
$ videos_dir $
74
71
thumbs_dir $
75
72
Bushel_common.url_term ~default:"https://crank.recoil.org" ~doc:"PeerTube base URL" $
+2
-2
stack/bushel/bin/dune
+2
-2
stack/bushel/bin/dune
···
9
9
(package bushel)
10
10
(modules bushel_main bushel_bibtex bushel_doi bushel_ideas bushel_info bushel_missing bushel_note_doi bushel_obsidian bushel_paper bushel_paper_classify bushel_paper_tex bushel_video bushel_video_thumbs bushel_thumbs bushel_faces bushel_links bushel_search)
11
11
(flags (:standard -w -69))
12
-
(libraries bushel bushel_common cmdliner cohttp-lwt-unix lwt.unix yaml ezjsonm zotero-translation peertube fmt fmt.cli fmt.tty logs logs.cli logs.fmt cmarkit karakeep uri unix ptime.clock.os crockford))
12
+
(libraries bushel bushel_common cmdliner eio eio_main yaml ezjsonm zotero-translation peertubee fmt fmt.cli fmt.tty logs logs.cli logs.fmt cmarkit karakeepe uri unix ptime.clock.os crockford immiche))
13
13
14
14
(executable
15
15
(name bushel_typesense)
···
17
17
(package bushel)
18
18
(modules bushel_typesense)
19
19
(flags (:standard -w -69))
20
-
(libraries bushel bushel_common cmdliner lwt.unix))
20
+
(libraries bushel bushel_common cmdliner eio eio_main))
+7
-5
stack/bushel/bushel.opam
+7
-5
stack/bushel/bushel.opam
···
18
18
"bytesrw"
19
19
"jekyll-format"
20
20
"yaml"
21
-
"lwt"
22
-
"cohttp-lwt-unix"
21
+
"eio"
22
+
"eio_main"
23
+
"requests"
23
24
"fmt"
24
-
"peertube"
25
-
"karakeep"
26
-
"typesense-client"
25
+
"peertubee"
26
+
"karakeepe"
27
+
"typesense-cliente"
28
+
"immiche"
27
29
"cmdliner" {>= "2.0.0"}
28
30
"odoc" {with-doc}
29
31
]
+7
-42
stack/bushel/dune-project
+7
-42
stack/bushel/dune-project
···
22
22
bytesrw
23
23
jekyll-format
24
24
yaml
25
-
lwt
26
-
cohttp-lwt-unix
25
+
eio
26
+
eio_main
27
+
requests
27
28
fmt
28
-
peertube
29
-
karakeep
30
-
typesense-client
29
+
peertubee
30
+
karakeepe
31
+
typesense-cliente
32
+
immiche
31
33
(cmdliner (>= 2.0.0))))
32
-
33
-
(package
34
-
(name peertube)
35
-
(synopsis "PeerTube API client")
36
-
(description "Client for interacting with PeerTube instances")
37
-
(depends
38
-
(ocaml (>= "5.2.0"))
39
-
ezjsonm
40
-
lwt
41
-
cohttp-lwt-unix
42
-
ptime
43
-
fmt))
44
-
45
-
(package
46
-
(name karakeep)
47
-
(synopsis "Karakeep API client for Bushel")
48
-
(description "Karakeep API client to retrieve bookmarks from Karakeep instances")
49
-
(depends
50
-
(ocaml (>= "5.2.0"))
51
-
ezjsonm
52
-
lwt
53
-
cohttp-lwt-unix
54
-
ptime
55
-
fmt))
56
-
57
-
(package
58
-
(name typesense-client)
59
-
(synopsis "Standalone Typesense client for OCaml")
60
-
(description "A standalone Typesense client that can be compiled to JavaScript")
61
-
(depends
62
-
(ocaml (>= "5.2.0"))
63
-
ezjsonm
64
-
lwt
65
-
cohttp-lwt-unix
66
-
ptime
67
-
fmt
68
-
uri))
-35
stack/bushel/karakeep.opam
-35
stack/bushel/karakeep.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "Karakeep API client for Bushel"
4
-
description:
5
-
"Karakeep API client to retrieve bookmarks from Karakeep instances"
6
-
maintainer: ["anil@recoil.org"]
7
-
authors: ["Anil Madhavapeddy"]
8
-
license: "ISC"
9
-
homepage: "https://github.com/avsm/bushel"
10
-
bug-reports: "https://github.com/avsm/bushel/issues"
11
-
depends: [
12
-
"dune" {>= "3.17"}
13
-
"ocaml" {>= "5.2.0"}
14
-
"ezjsonm"
15
-
"lwt"
16
-
"cohttp-lwt-unix"
17
-
"ptime"
18
-
"fmt"
19
-
"odoc" {with-doc}
20
-
]
21
-
build: [
22
-
["dune" "subst"] {dev}
23
-
[
24
-
"dune"
25
-
"build"
26
-
"-p"
27
-
name
28
-
"-j"
29
-
jobs
30
-
"@install"
31
-
"@runtest" {with-test}
32
-
"@doc" {with-doc}
33
-
]
34
-
]
35
-
dev-repo: "git+https://github.com/avsm/bushel.git"
-4
stack/bushel/karakeep/dune
-4
stack/bushel/karakeep/dune
-568
stack/bushel/karakeep/karakeep.ml
-568
stack/bushel/karakeep/karakeep.ml
···
1
-
(** Karakeep API client implementation *)
2
-
3
-
open Lwt.Infix
4
-
5
-
module J = Ezjsonm
6
-
7
-
(** Type representing a Karakeep bookmark *)
8
-
type bookmark = {
9
-
id: string;
10
-
title: string option;
11
-
url: string;
12
-
note: string option;
13
-
created_at: Ptime.t;
14
-
updated_at: Ptime.t option;
15
-
favourited: bool;
16
-
archived: bool;
17
-
tags: string list;
18
-
tagging_status: string option;
19
-
summary: string option;
20
-
content: (string * string) list;
21
-
assets: (string * string) list;
22
-
}
23
-
24
-
(** Type for Karakeep API response containing bookmarks *)
25
-
type bookmark_response = {
26
-
total: int;
27
-
data: bookmark list;
28
-
next_cursor: string option;
29
-
}
30
-
31
-
(** Parse a date string to Ptime.t, defaulting to epoch if invalid *)
32
-
let parse_date str =
33
-
match Ptime.of_rfc3339 str with
34
-
| Ok (date, _, _) -> date
35
-
| Error _ ->
36
-
Fmt.epr "Warning: could not parse date '%s'\n" str;
37
-
(* Default to epoch time *)
38
-
let span_opt = Ptime.Span.of_d_ps (0, 0L) in
39
-
match span_opt with
40
-
| None -> failwith "Internal error: couldn't create epoch time span"
41
-
| Some span ->
42
-
match Ptime.of_span span with
43
-
| Some t -> t
44
-
| None -> failwith "Internal error: couldn't create epoch time"
45
-
46
-
(** Extract a string field from JSON, returns None if not present or not a string *)
47
-
let get_string_opt json path =
48
-
try Some (J.find json path |> J.get_string)
49
-
with _ -> None
50
-
51
-
(** Extract a string list field from JSON, returns empty list if not present *)
52
-
let get_string_list json path =
53
-
try
54
-
let items_json = J.find json path in
55
-
J.get_list (fun tag -> J.find tag ["name"] |> J.get_string) items_json
56
-
with _ -> []
57
-
58
-
(** Extract a boolean field from JSON, with default value *)
59
-
let get_bool_def json path default =
60
-
try J.find json path |> J.get_bool
61
-
with _ -> default
62
-
63
-
(** Parse a single bookmark from Karakeep JSON *)
64
-
let parse_bookmark json =
65
-
(* Remove debug prints for production *)
66
-
(* Printf.eprintf "%s\n%!" (J.value_to_string json); *)
67
-
68
-
let id =
69
-
try J.find json ["id"] |> J.get_string
70
-
with e ->
71
-
prerr_endline (Fmt.str "Error parsing bookmark ID: %s" (Printexc.to_string e));
72
-
prerr_endline (Fmt.str "JSON: %s" (J.value_to_string json));
73
-
failwith "Unable to parse bookmark ID"
74
-
in
75
-
76
-
(* Title can be null *)
77
-
let title =
78
-
try Some (J.find json ["title"] |> J.get_string)
79
-
with _ -> None
80
-
in
81
-
(* Remove debug prints for production *)
82
-
(* Printf.eprintf "%s -> %s\n%!" id (match title with None -> "???" | Some v -> v); *)
83
-
(* Get URL - try all possible locations *)
84
-
let url =
85
-
try J.find json ["url"] |> J.get_string (* Direct url field *)
86
-
with _ -> try
87
-
J.find json ["content"; "url"] |> J.get_string (* Inside content.url *)
88
-
with _ -> try
89
-
J.find json ["content"; "sourceUrl"] |> J.get_string (* Inside content.sourceUrl *)
90
-
with _ ->
91
-
(* For assets/PDF type links *)
92
-
match J.find_opt json ["content"; "type"] with
93
-
| Some (`String "asset") ->
94
-
(* Extract URL from sourceUrl in content *)
95
-
(try J.find json ["content"; "sourceUrl"] |> J.get_string
96
-
with _ ->
97
-
(match J.find_opt json ["id"] with
98
-
| Some (`String id) -> "karakeep-asset://" ^ id
99
-
| _ -> failwith "No URL or asset ID found in bookmark"))
100
-
| _ ->
101
-
(* Debug output to understand what we're getting *)
102
-
prerr_endline (Fmt.str "Bookmark JSON structure: %s" (J.value_to_string json));
103
-
failwith "No URL found in bookmark"
104
-
in
105
-
106
-
let note = get_string_opt json ["note"] in
107
-
108
-
(* Parse dates *)
109
-
let created_at =
110
-
try J.find json ["createdAt"] |> J.get_string |> parse_date
111
-
with _ ->
112
-
try J.find json ["created_at"] |> J.get_string |> parse_date
113
-
with _ -> failwith "No creation date found"
114
-
in
115
-
116
-
let updated_at =
117
-
try Some (J.find json ["updatedAt"] |> J.get_string |> parse_date)
118
-
with _ ->
119
-
try Some (J.find json ["modifiedAt"] |> J.get_string |> parse_date)
120
-
with _ -> None
121
-
in
122
-
123
-
let favourited = get_bool_def json ["favourited"] false in
124
-
let archived = get_bool_def json ["archived"] false in
125
-
let tags = get_string_list json ["tags"] in
126
-
127
-
(* Extract additional metadata *)
128
-
let tagging_status = get_string_opt json ["taggingStatus"] in
129
-
let summary = get_string_opt json ["summary"] in
130
-
131
-
(* Extract content details *)
132
-
let content =
133
-
try
134
-
let content_json = J.find json ["content"] in
135
-
let rec extract_fields acc = function
136
-
| [] -> acc
137
-
| (k, v) :: rest ->
138
-
let value = match v with
139
-
| `String s -> s
140
-
| `Bool b -> string_of_bool b
141
-
| `Float f -> string_of_float f
142
-
| `Null -> "null"
143
-
| _ -> "complex_value" (* For objects and arrays *)
144
-
in
145
-
extract_fields ((k, value) :: acc) rest
146
-
in
147
-
match content_json with
148
-
| `O fields -> extract_fields [] fields
149
-
| _ -> []
150
-
with _ -> []
151
-
in
152
-
153
-
(* Extract assets *)
154
-
let assets =
155
-
try
156
-
let assets_json = J.find json ["assets"] in
157
-
J.get_list (fun asset_json ->
158
-
let id = J.find asset_json ["id"] |> J.get_string in
159
-
let asset_type =
160
-
try J.find asset_json ["assetType"] |> J.get_string
161
-
with _ -> "unknown"
162
-
in
163
-
(id, asset_type)
164
-
) assets_json
165
-
with _ -> []
166
-
in
167
-
168
-
{ id; title; url; note; created_at; updated_at; favourited; archived; tags;
169
-
tagging_status; summary; content; assets }
170
-
171
-
(** Parse a Karakeep bookmark response *)
172
-
let parse_bookmark_response json =
173
-
(* The response format is different based on endpoint, need to handle both structures *)
174
-
(* Print the whole JSON structure for debugging *)
175
-
prerr_endline (Fmt.str "Full response JSON: %s" (J.value_to_string json));
176
-
177
-
try
178
-
(* Standard list format with total count *)
179
-
let total = J.find json ["total"] |> J.get_int in
180
-
let bookmarks_json = J.find json ["data"] in
181
-
prerr_endline "Found bookmarks in data array";
182
-
let data = J.get_list parse_bookmark bookmarks_json in
183
-
184
-
(* Try to extract nextCursor if available *)
185
-
let next_cursor =
186
-
try Some (J.find json ["nextCursor"] |> J.get_string)
187
-
with _ -> None
188
-
in
189
-
190
-
{ total; data; next_cursor }
191
-
with e1 ->
192
-
prerr_endline (Fmt.str "First format parse error: %s" (Printexc.to_string e1));
193
-
try
194
-
(* Format with bookmarks array *)
195
-
let bookmarks_json = J.find json ["bookmarks"] in
196
-
prerr_endline "Found bookmarks in bookmarks array";
197
-
let data =
198
-
try J.get_list parse_bookmark bookmarks_json
199
-
with e ->
200
-
prerr_endline (Fmt.str "Error parsing bookmarks array: %s" (Printexc.to_string e));
201
-
prerr_endline (Fmt.str "First bookmark sample: %s"
202
-
(try J.value_to_string (List.hd (J.get_list (fun x -> x) bookmarks_json))
203
-
with _ -> "Could not extract sample"));
204
-
[]
205
-
in
206
-
207
-
(* Try to extract nextCursor if available *)
208
-
let next_cursor =
209
-
try Some (J.find json ["nextCursor"] |> J.get_string)
210
-
with _ -> None
211
-
in
212
-
213
-
{ total = List.length data; data; next_cursor }
214
-
with e2 ->
215
-
prerr_endline (Fmt.str "Second format parse error: %s" (Printexc.to_string e2));
216
-
try
217
-
(* Check if it's an error response *)
218
-
let error = J.find json ["error"] |> J.get_string in
219
-
let message =
220
-
try J.find json ["message"] |> J.get_string
221
-
with _ -> "Unknown error"
222
-
in
223
-
prerr_endline (Fmt.str "API Error: %s - %s" error message);
224
-
{ total = 0; data = []; next_cursor = None }
225
-
with _ ->
226
-
try
227
-
(* Alternate format without total (for endpoints like /tags/<id>/bookmarks) *)
228
-
prerr_endline "Trying alternate array format";
229
-
230
-
(* Debug the structure to identify the format *)
231
-
prerr_endline (Fmt.str "JSON structure keys: %s"
232
-
(match json with
233
-
| `O fields ->
234
-
String.concat ", " (List.map (fun (k, _) -> k) fields)
235
-
| _ -> "not an object"));
236
-
237
-
(* Check if it has a nextCursor but bookmarks are nested differently *)
238
-
if J.find_opt json ["nextCursor"] <> None then begin
239
-
prerr_endline "Found nextCursor, checking alternate structures";
240
-
241
-
(* Try different bookmark container paths *)
242
-
let bookmarks_json =
243
-
try Some (J.find json ["data"])
244
-
with _ -> None
245
-
in
246
-
247
-
match bookmarks_json with
248
-
| Some json_array ->
249
-
prerr_endline "Found bookmarks in data field";
250
-
begin try
251
-
let data = J.get_list parse_bookmark json_array in
252
-
let next_cursor =
253
-
try Some (J.find json ["nextCursor"] |> J.get_string)
254
-
with _ -> None
255
-
in
256
-
{ total = List.length data; data; next_cursor }
257
-
with e ->
258
-
prerr_endline (Fmt.str "Error parsing bookmarks from data: %s" (Printexc.to_string e));
259
-
{ total = 0; data = []; next_cursor = None }
260
-
end
261
-
| None ->
262
-
prerr_endline "No bookmarks found in alternate structure";
263
-
{ total = 0; data = []; next_cursor = None }
264
-
end
265
-
else begin
266
-
(* Check if it's an array at root level *)
267
-
match json with
268
-
| `A _ ->
269
-
let data =
270
-
try J.get_list parse_bookmark json
271
-
with e ->
272
-
prerr_endline (Fmt.str "Error parsing root array: %s" (Printexc.to_string e));
273
-
[]
274
-
in
275
-
{ total = List.length data; data; next_cursor = None }
276
-
| _ ->
277
-
prerr_endline "Not an array at root level";
278
-
{ total = 0; data = []; next_cursor = None }
279
-
end
280
-
with e3 ->
281
-
prerr_endline (Fmt.str "Third format parse error: %s" (Printexc.to_string e3));
282
-
{ total = 0; data = []; next_cursor = None }
283
-
284
-
(** Helper function to consume and return response body data *)
285
-
let consume_body body =
286
-
Cohttp_lwt.Body.to_string body >>= fun _ ->
287
-
Lwt.return_unit
288
-
289
-
(** Fetch bookmarks from a Karakeep instance with pagination support *)
290
-
let fetch_bookmarks ~api_key ?(limit=50) ?(offset=0) ?cursor ?(include_content=false) ?filter_tags base_url =
291
-
let open Cohttp_lwt_unix in
292
-
293
-
(* Base URL for bookmarks API *)
294
-
let url_base = Fmt.str "%s/api/v1/bookmarks?limit=%d&includeContent=%b"
295
-
base_url limit include_content in
296
-
297
-
(* Add pagination parameter - either cursor or offset *)
298
-
let url =
299
-
match cursor with
300
-
| Some cursor_value ->
301
-
url_base ^ "&cursor=" ^ cursor_value
302
-
| None ->
303
-
url_base ^ "&offset=" ^ string_of_int offset
304
-
in
305
-
306
-
(* Add tags filter if provided *)
307
-
let url = match filter_tags with
308
-
| Some tags when tags <> [] ->
309
-
(* URL encode each tag and join with commas *)
310
-
let encoded_tags =
311
-
List.map (fun tag ->
312
-
Uri.pct_encode ~component:`Query_key tag
313
-
) tags
314
-
in
315
-
let tags_param = String.concat "," encoded_tags in
316
-
prerr_endline (Fmt.str "Adding tags filter: %s" tags_param);
317
-
url ^ "&tags=" ^ tags_param
318
-
| _ -> url
319
-
in
320
-
321
-
(* Set up headers with API key *)
322
-
let headers = Cohttp.Header.init ()
323
-
|> fun h -> Cohttp.Header.add h "Authorization" ("Bearer " ^ api_key) in
324
-
325
-
prerr_endline (Fmt.str "Fetching bookmarks from: %s" url);
326
-
327
-
(* Make the request *)
328
-
Lwt.catch
329
-
(fun () ->
330
-
Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->
331
-
if resp.status = `OK then
332
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
333
-
prerr_endline (Fmt.str "Received %d bytes of response data" (String.length body_str));
334
-
335
-
Lwt.catch
336
-
(fun () ->
337
-
let json = J.from_string body_str in
338
-
Lwt.return (parse_bookmark_response json)
339
-
)
340
-
(fun e ->
341
-
prerr_endline (Fmt.str "JSON parsing error: %s" (Printexc.to_string e));
342
-
prerr_endline (Fmt.str "Response body (first 200 chars): %s"
343
-
(if String.length body_str > 200 then String.sub body_str 0 200 ^ "..." else body_str));
344
-
Lwt.fail e
345
-
)
346
-
else
347
-
let status_code = Cohttp.Code.code_of_status resp.status in
348
-
consume_body body >>= fun _ ->
349
-
prerr_endline (Fmt.str "HTTP error %d" status_code);
350
-
Lwt.fail_with (Fmt.str "HTTP error: %d" status_code)
351
-
)
352
-
(fun e ->
353
-
prerr_endline (Fmt.str "Network error: %s" (Printexc.to_string e));
354
-
Lwt.fail e
355
-
)
356
-
357
-
(** Fetch all bookmarks from a Karakeep instance using pagination *)
358
-
let fetch_all_bookmarks ~api_key ?(page_size=50) ?max_pages ?filter_tags ?(include_content=false) base_url =
359
-
let rec fetch_pages page_num cursor acc _total_count =
360
-
(* Use cursor if available, otherwise use offset-based pagination *)
361
-
(match cursor with
362
-
| Some cursor_str -> fetch_bookmarks ~api_key ~limit:page_size ~cursor:cursor_str ~include_content ?filter_tags base_url
363
-
| None -> fetch_bookmarks ~api_key ~limit:page_size ~offset:(page_num * page_size) ~include_content ?filter_tags base_url)
364
-
>>= fun response ->
365
-
366
-
let all_bookmarks = acc @ response.data in
367
-
368
-
(* Determine if we need to fetch more pages *)
369
-
let more_available =
370
-
match response.next_cursor with
371
-
| Some _ -> true (* We have a cursor, so there are more results *)
372
-
| None ->
373
-
(* Fall back to offset-based check *)
374
-
let fetched_count = (page_num * page_size) + List.length response.data in
375
-
fetched_count < response.total
376
-
in
377
-
378
-
let under_max_pages = match max_pages with
379
-
| None -> true
380
-
| Some max -> page_num + 1 < max
381
-
in
382
-
383
-
if more_available && under_max_pages then
384
-
fetch_pages (page_num + 1) response.next_cursor all_bookmarks response.total
385
-
else
386
-
Lwt.return all_bookmarks
387
-
in
388
-
fetch_pages 0 None [] 0
389
-
390
-
(** Fetch detailed information for a single bookmark by ID *)
391
-
let fetch_bookmark_details ~api_key base_url bookmark_id =
392
-
let open Cohttp_lwt_unix in
393
-
let url = Fmt.str "%s/api/v1/bookmarks/%s" base_url bookmark_id in
394
-
395
-
(* Set up headers with API key *)
396
-
let headers = Cohttp.Header.init ()
397
-
|> fun h -> Cohttp.Header.add h "Authorization" ("Bearer " ^ api_key) in
398
-
399
-
Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->
400
-
if resp.status = `OK then
401
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
402
-
let json = J.from_string body_str in
403
-
Lwt.return (parse_bookmark json)
404
-
else
405
-
let status_code = Cohttp.Code.code_of_status resp.status in
406
-
consume_body body >>= fun () ->
407
-
Lwt.fail_with (Fmt.str "HTTP error: %d" status_code)
408
-
409
-
(** Get the asset URL for a given asset ID *)
410
-
let get_asset_url base_url asset_id =
411
-
Fmt.str "%s/api/assets/%s" base_url asset_id
412
-
413
-
(** Fetch an asset from the Karakeep server as a binary string *)
414
-
let fetch_asset ~api_key base_url asset_id =
415
-
let open Cohttp_lwt_unix in
416
-
417
-
let url = get_asset_url base_url asset_id in
418
-
419
-
(* Set up headers with API key *)
420
-
let headers = Cohttp.Header.init ()
421
-
|> fun h -> Cohttp.Header.add h "Authorization" ("Bearer " ^ api_key) in
422
-
423
-
Client.get ~headers (Uri.of_string url) >>= fun (resp, body) ->
424
-
if resp.status = `OK then
425
-
Cohttp_lwt.Body.to_string body
426
-
else
427
-
let status_code = Cohttp.Code.code_of_status resp.status in
428
-
consume_body body >>= fun () ->
429
-
Lwt.fail_with (Fmt.str "Asset fetch error: %d" status_code)
430
-
431
-
(** Create a new bookmark in Karakeep with optional tags *)
432
-
let create_bookmark ~api_key ~url ?title ?note ?tags ?(favourited=false) ?(archived=false) base_url =
433
-
let open Cohttp_lwt_unix in
434
-
435
-
(* Prepare the bookmark request body *)
436
-
let body_obj = [
437
-
("type", `String "link");
438
-
("url", `String url);
439
-
("favourited", `Bool favourited);
440
-
("archived", `Bool archived);
441
-
] in
442
-
443
-
(* Add optional fields *)
444
-
let body_obj = match title with
445
-
| Some title_str -> ("title", `String title_str) :: body_obj
446
-
| None -> body_obj
447
-
in
448
-
449
-
let body_obj = match note with
450
-
| Some note_str -> ("note", `String note_str) :: body_obj
451
-
| None -> body_obj
452
-
in
453
-
454
-
(* Convert to JSON *)
455
-
let body_json = `O body_obj in
456
-
let body_str = J.to_string body_json in
457
-
458
-
(* Set up headers with API key *)
459
-
let headers = Cohttp.Header.init ()
460
-
|> fun h -> Cohttp.Header.add h "Authorization" ("Bearer " ^ api_key)
461
-
|> fun h -> Cohttp.Header.add h "Content-Type" "application/json"
462
-
in
463
-
464
-
(* Helper function to ensure we consume all response body data *)
465
-
let consume_body body =
466
-
Cohttp_lwt.Body.to_string body >>= fun _ ->
467
-
Lwt.return_unit
468
-
in
469
-
470
-
(* Create the bookmark *)
471
-
let url_endpoint = Fmt.str "%s/api/v1/bookmarks" base_url in
472
-
Client.post ~headers ~body:(Cohttp_lwt.Body.of_string body_str) (Uri.of_string url_endpoint) >>= fun (resp, body) ->
473
-
474
-
if resp.status = `Created || resp.status = `OK then
475
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
476
-
let json = J.from_string body_str in
477
-
let bookmark = parse_bookmark json in
478
-
479
-
(* If tags are provided, add them to the bookmark *)
480
-
(match tags with
481
-
| Some tag_list when tag_list <> [] ->
482
-
(* Prepare the tags request body *)
483
-
let tag_objects = List.map (fun tag_name ->
484
-
`O [("tagName", `String tag_name)]
485
-
) tag_list in
486
-
487
-
let tags_body = `O [("tags", `A tag_objects)] in
488
-
let tags_body_str = J.to_string tags_body in
489
-
490
-
(* Add tags to the bookmark *)
491
-
let tags_url = Fmt.str "%s/api/v1/bookmarks/%s/tags" base_url bookmark.id in
492
-
Client.post ~headers ~body:(Cohttp_lwt.Body.of_string tags_body_str) (Uri.of_string tags_url) >>= fun (resp, body) ->
493
-
494
-
(* Always consume the response body *)
495
-
consume_body body >>= fun () ->
496
-
497
-
if resp.status = `OK then
498
-
(* Fetch the bookmark again to get updated tags *)
499
-
fetch_bookmark_details ~api_key base_url bookmark.id
500
-
else
501
-
(* Return the bookmark without tags if tag addition failed *)
502
-
Lwt.return bookmark
503
-
| _ -> Lwt.return bookmark)
504
-
else
505
-
let status_code = Cohttp.Code.code_of_status resp.status in
506
-
Cohttp_lwt.Body.to_string body >>= fun error_body ->
507
-
Lwt.fail_with (Fmt.str "Failed to create bookmark. HTTP error: %d. Details: %s" status_code error_body)
508
-
509
-
(** Convert a Karakeep bookmark to Bushel.Link.t compatible structure *)
510
-
let to_bushel_link ?base_url bookmark =
511
-
(* Try to find the best title from multiple possible sources *)
512
-
let description =
513
-
match bookmark.title with
514
-
| Some title when title <> "" -> title
515
-
| _ ->
516
-
(* Check if there's a title in the content *)
517
-
let content_title = List.assoc_opt "title" bookmark.content in
518
-
match content_title with
519
-
| Some title when title <> "" && title <> "null" -> title
520
-
| _ -> bookmark.url
521
-
in
522
-
let date = Ptime.to_date bookmark.created_at in
523
-
524
-
(* Build selective metadata - only include useful fields *)
525
-
let metadata =
526
-
(match bookmark.summary with Some s -> [("summary", s)] | None -> []) @
527
-
(* Extract key asset IDs *)
528
-
(List.filter_map (fun (id, asset_type) ->
529
-
match asset_type with
530
-
| "screenshot" | "bannerImage" -> Some (asset_type, id)
531
-
| _ -> None
532
-
) bookmark.assets) @
533
-
(* Extract only the favicon from content *)
534
-
(List.filter_map (fun (k, v) ->
535
-
if k = "favicon" && v <> "" && v <> "null" then Some ("favicon", v) else None
536
-
) bookmark.content)
537
-
in
538
-
539
-
(* Create karakeep data if base_url is provided *)
540
-
let karakeep =
541
-
match base_url with
542
-
| Some url ->
543
-
Some {
544
-
Bushel.Link.remote_url = url;
545
-
id = bookmark.id;
546
-
tags = bookmark.tags;
547
-
metadata = metadata;
548
-
}
549
-
| None -> None
550
-
in
551
-
552
-
(* Extract bushel slugs from tags *)
553
-
let bushel_slugs =
554
-
List.filter_map (fun tag ->
555
-
if String.starts_with ~prefix:"bushel:" tag then
556
-
Some (String.sub tag 7 (String.length tag - 7))
557
-
else
558
-
None
559
-
) bookmark.tags
560
-
in
561
-
562
-
(* Create bushel data if we have bushel-related information *)
563
-
let bushel =
564
-
if bushel_slugs = [] then None
565
-
else Some { Bushel.Link.slugs = bushel_slugs; tags = [] }
566
-
in
567
-
568
-
{ Bushel.Link.url = bookmark.url; date; description; karakeep; bushel }
+44
-24
stack/bushel/karakeep/karakeep.mli
stack/karakeepe/karakeepe.mli
+44
-24
stack/bushel/karakeep/karakeep.mli
stack/karakeepe/karakeepe.mli
···
1
-
(** Karakeep API client interface *)
1
+
(** Karakeepe API client interface (Eio version) *)
2
2
3
3
(** Type representing a Karakeep bookmark *)
4
4
type bookmark = {
···
31
31
val parse_bookmark_response : Ezjsonm.value -> bookmark_response
32
32
33
33
(** Fetch bookmarks from a Karakeep instance with pagination support
34
+
@param sw Eio switch for resource management
35
+
@param env Eio environment (provides clock and network)
34
36
@param api_key API key for authentication
35
37
@param limit Number of bookmarks to fetch per page (default: 50)
36
38
@param offset Starting index for pagination (0-based) (default: 0)
···
38
40
@param include_content Whether to include full content (default: false)
39
41
@param filter_tags Optional list of tags to filter by
40
42
@param base_url Base URL of the Karakeep instance
41
-
@return A Lwt promise with the bookmark response *)
42
-
val fetch_bookmarks :
43
-
api_key:string ->
44
-
?limit:int ->
45
-
?offset:int ->
43
+
@return The bookmark response *)
44
+
val fetch_bookmarks :
45
+
sw:Eio.Switch.t ->
46
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic] Eio.Net.ty ] Eio.Resource.t; .. > ->
47
+
api_key:string ->
48
+
?limit:int ->
49
+
?offset:int ->
46
50
?cursor:string ->
47
51
?include_content:bool ->
48
52
?filter_tags:string list ->
49
-
string ->
50
-
bookmark_response Lwt.t
53
+
string ->
54
+
bookmark_response
51
55
52
56
(** Fetch all bookmarks from a Karakeep instance using pagination
57
+
@param sw Eio switch for resource management
58
+
@param env Eio environment (provides clock and network)
53
59
@param api_key API key for authentication
54
60
@param page_size Number of bookmarks to fetch per page (default: 50)
55
61
@param max_pages Maximum number of pages to fetch (None for all pages)
56
62
@param filter_tags Optional list of tags to filter by
57
63
@param include_content Whether to include full content (default: false)
58
64
@param base_url Base URL of the Karakeep instance
59
-
@return A Lwt promise with all bookmarks combined *)
60
-
val fetch_all_bookmarks :
61
-
api_key:string ->
62
-
?page_size:int ->
63
-
?max_pages:int ->
65
+
@return All bookmarks combined *)
66
+
val fetch_all_bookmarks :
67
+
sw:Eio.Switch.t ->
68
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic] Eio.Net.ty ] Eio.Resource.t; .. > ->
69
+
api_key:string ->
70
+
?page_size:int ->
71
+
?max_pages:int ->
64
72
?filter_tags:string list ->
65
73
?include_content:bool ->
66
-
string ->
67
-
bookmark list Lwt.t
74
+
string ->
75
+
bookmark list
68
76
69
77
(** Fetch detailed information for a single bookmark by ID
78
+
@param sw Eio switch for resource management
79
+
@param env Eio environment (provides clock and network)
70
80
@param api_key API key for authentication
71
81
@param base_url Base URL of the Karakeep instance
72
82
@param bookmark_id ID of the bookmark to fetch
73
-
@return A Lwt promise with the complete bookmark details *)
74
-
val fetch_bookmark_details :
83
+
@return The complete bookmark details *)
84
+
val fetch_bookmark_details :
85
+
sw:Eio.Switch.t ->
86
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic] Eio.Net.ty ] Eio.Resource.t; .. > ->
75
87
api_key:string ->
76
-
string ->
77
-
string ->
78
-
bookmark Lwt.t
88
+
string ->
89
+
string ->
90
+
bookmark
79
91
80
92
(** Convert a Karakeep bookmark to Bushel.Link.t compatible structure
81
93
@param base_url Optional base URL of the Karakeep instance (for karakeep_id) *)
82
94
val to_bushel_link : ?base_url:string -> bookmark -> Bushel.Link.t
83
95
84
96
(** Fetch an asset from the Karakeep server as a binary string
97
+
@param sw Eio switch for resource management
98
+
@param env Eio environment (provides clock and network)
85
99
@param api_key API key for authentication
86
100
@param base_url Base URL of the Karakeep instance
87
101
@param asset_id ID of the asset to fetch
88
-
@return A Lwt promise with the binary asset data *)
102
+
@return The binary asset data *)
89
103
val fetch_asset :
104
+
sw:Eio.Switch.t ->
105
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic] Eio.Net.ty ] Eio.Resource.t; .. > ->
90
106
api_key:string ->
91
107
string ->
92
108
string ->
93
-
string Lwt.t
109
+
string
94
110
95
111
(** Get the asset URL for a given asset ID
96
112
@param base_url Base URL of the Karakeep instance
···
102
118
string
103
119
104
120
(** Create a new bookmark in Karakeep with optional tags
121
+
@param sw Eio switch for resource management
122
+
@param env Eio environment (provides clock and network)
105
123
@param api_key API key for authentication
106
124
@param url The URL to bookmark
107
125
@param title Optional title for the bookmark
···
110
128
@param favourited Whether the bookmark should be marked as favourite (default: false)
111
129
@param archived Whether the bookmark should be archived (default: false)
112
130
@param base_url Base URL of the Karakeep instance
113
-
@return A Lwt promise with the created bookmark *)
131
+
@return The created bookmark *)
114
132
val create_bookmark :
133
+
sw:Eio.Switch.t ->
134
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic] Eio.Net.ty ] Eio.Resource.t; .. > ->
115
135
api_key:string ->
116
136
url:string ->
117
137
?title:string ->
···
120
140
?favourited:bool ->
121
141
?archived:bool ->
122
142
string ->
123
-
bookmark Lwt.t
143
+
bookmark
+4
-3
stack/bushel/lib/dune
+4
-3
stack/bushel/lib/dune
+100
-99
stack/bushel/lib/typesense.ml
+100
-99
stack/bushel/lib/typesense.ml
···
1
-
open Lwt.Syntax
2
-
open Cohttp_lwt_unix
3
-
4
1
(** TODO:claude Typesense API client for Bushel *)
5
2
6
3
type config = {
···
9
6
openai_key : string;
10
7
}
11
8
12
-
type error =
9
+
type error =
13
10
| Http_error of int * string
14
11
| Json_error of string
15
12
| Connection_error of string
···
21
18
22
19
(** TODO:claude Create authentication headers for Typesense API *)
23
20
let auth_headers api_key =
24
-
Cohttp.Header.of_list [
25
-
("X-TYPESENSE-API-KEY", api_key);
26
-
("Content-Type", "application/json");
27
-
]
21
+
Requests.Headers.empty
22
+
|> Requests.Headers.set "X-TYPESENSE-API-KEY" api_key
23
+
|> Requests.Headers.set "Content-Type" "application/json"
28
24
29
25
(** TODO:claude Make HTTP request to Typesense API *)
30
-
let make_request ?(meth=`GET) ?(body="") config path =
26
+
let make_request ~sw ~env ?(meth=`GET) ?(body="") config path =
31
27
let uri = Uri.of_string (config.endpoint ^ path) in
32
28
let headers = auth_headers config.api_key in
33
-
let body = if body = "" then `Empty else `String body in
34
-
Lwt.catch (fun () ->
35
-
let* resp, body = Client.call ~headers ~body meth uri in
36
-
let status = Cohttp.Code.code_of_status (Response.status resp) in
37
-
let* body_str = Cohttp_lwt.Body.to_string body in
29
+
let body = if body = "" then None else Some (Requests.Body.of_string Requests.Mime.json body) in
30
+
31
+
try
32
+
let response = Requests.One.request ~sw
33
+
~clock:env#clock ~net:env#net
34
+
?body
35
+
~headers
36
+
~method_:meth
37
+
(Uri.to_string uri)
38
+
in
39
+
40
+
let status = Requests.Response.status_code response in
41
+
let body_flow = Requests.Response.body response in
42
+
let body_str = Eio.Flow.read_all body_flow in
43
+
38
44
if status >= 200 && status < 300 then
39
-
Lwt.return_ok body_str
45
+
Ok body_str
40
46
else
41
-
Lwt.return_error (Http_error (status, body_str))
42
-
) (fun exn ->
43
-
Lwt.return_error (Connection_error (Printexc.to_string exn))
44
-
)
47
+
Error (Http_error (status, body_str))
48
+
with exn ->
49
+
Error (Connection_error (Printexc.to_string exn))
45
50
46
51
(** TODO:claude Create a collection with given schema *)
47
-
let create_collection config (schema : Ezjsonm.value) =
52
+
let create_collection ~sw ~env config (schema : Ezjsonm.value) =
48
53
let body = Ezjsonm.value_to_string schema in
49
-
make_request ~meth:`POST ~body config "/collections"
54
+
make_request ~sw ~env ~meth:`POST ~body config "/collections"
50
55
51
56
(** TODO:claude Check if collection exists *)
52
-
let collection_exists config name =
53
-
let* result = make_request config ("/collections/" ^ name) in
57
+
let collection_exists ~sw ~env config name =
58
+
let result = make_request ~sw ~env config ("/collections/" ^ name) in
54
59
match result with
55
-
| Ok _ -> Lwt.return true
56
-
| Error (Http_error (404, _)) -> Lwt.return false
57
-
| Error _ -> Lwt.return false
60
+
| Ok _ -> true
61
+
| Error (Http_error (404, _)) -> false
62
+
| Error _ -> false
58
63
59
64
(** TODO:claude Delete a collection *)
60
-
let delete_collection config name =
61
-
make_request ~meth:`DELETE config ("/collections/" ^ name)
65
+
let delete_collection ~sw ~env config name =
66
+
make_request ~sw ~env ~meth:`DELETE config ("/collections/" ^ name)
62
67
63
68
(** TODO:claude Upload documents to a collection in batch *)
64
-
let upload_documents config collection_name (documents : Ezjsonm.value list) =
69
+
let upload_documents ~sw ~env config collection_name (documents : Ezjsonm.value list) =
65
70
let jsonl_lines = List.map (fun doc -> Ezjsonm.value_to_string doc) documents in
66
71
let body = String.concat "\n" jsonl_lines in
67
-
make_request ~meth:`POST ~body config
72
+
make_request ~sw ~env ~meth:`POST ~body config
68
73
(Printf.sprintf "/collections/%s/documents/import?action=upsert" collection_name)
69
74
70
75
···
340
345
dict updated_schema
341
346
342
347
(** TODO:claude Upload all bushel objects to their respective collections *)
343
-
let upload_all config entries =
344
-
let* () = Lwt_io.write Lwt_io.stdout "Uploading bushel data to Typesense\n" in
348
+
let upload_all ~sw ~env config entries =
349
+
print_string "Uploading bushel data to Typesense\n";
345
350
346
351
let contacts = Entry.contacts entries in
347
352
let papers = Entry.papers entries in
···
360
365
] in
361
366
362
367
let upload_collection ((name, schema, documents) : string * Ezjsonm.value * Ezjsonm.value list) =
363
-
let* () = Lwt_io.write Lwt_io.stdout (Fmt.str "Processing collection: %s\n" name) in
364
-
let* exists = collection_exists config name in
365
-
let* () =
366
-
if exists then (
367
-
let* () = Lwt_io.write Lwt_io.stdout (Fmt.str "Collection %s exists, deleting...\n" name) in
368
-
let* result = delete_collection config name in
369
-
match result with
370
-
| Ok _ -> Lwt_io.write Lwt_io.stdout (Fmt.str "Deleted collection %s\n" name)
371
-
| Error err ->
372
-
let err_str = Fmt.str "%a" pp_error err in
373
-
Lwt_io.write Lwt_io.stdout (Fmt.str "Failed to delete collection %s: %s\n" name err_str)
374
-
) else
375
-
Lwt.return_unit
376
-
in
377
-
let* () = Lwt_io.write Lwt_io.stdout (Fmt.str "Creating collection %s with %d documents\n" name (List.length documents)) in
378
-
let* result = create_collection config schema in
368
+
Printf.printf "Processing collection: %s\n%!" name;
369
+
let exists = collection_exists ~sw ~env config name in
370
+
(if exists then (
371
+
Printf.printf "Collection %s exists, deleting...\n%!" name;
372
+
let result = delete_collection ~sw ~env config name in
373
+
match result with
374
+
| Ok _ -> Printf.printf "Deleted collection %s\n%!" name
375
+
| Error err ->
376
+
let err_str = Fmt.str "%a" pp_error err in
377
+
Printf.printf "Failed to delete collection %s: %s\n%!" name err_str
378
+
));
379
+
Printf.printf "Creating collection %s with %d documents\n%!" name (List.length documents);
380
+
let result = create_collection ~sw ~env config schema in
379
381
match result with
380
382
| Ok _ ->
381
-
let* () = Lwt_io.write Lwt_io.stdout (Fmt.str "Created collection %s\n" name) in
383
+
Printf.printf "Created collection %s\n%!" name;
382
384
if documents = [] then
383
-
Lwt_io.write Lwt_io.stdout (Fmt.str "No documents to upload for %s\n" name)
385
+
Printf.printf "No documents to upload for %s\n%!" name
384
386
else (
385
-
let* result = upload_documents config name documents in
387
+
let result = upload_documents ~sw ~env config name documents in
386
388
match result with
387
-
| Ok response ->
389
+
| Ok response ->
388
390
(* Count successes and failures *)
389
391
let lines = String.split_on_char '\n' response in
390
-
let successes = List.fold_left (fun acc line ->
392
+
let successes = List.fold_left (fun acc line ->
391
393
if String.contains line ':' && Str.string_match (Str.regexp ".*success.*true.*") line 0 then acc + 1 else acc) 0 lines in
392
-
let failures = List.fold_left (fun acc line ->
394
+
let failures = List.fold_left (fun acc line ->
393
395
if String.contains line ':' && Str.string_match (Str.regexp ".*success.*false.*") line 0 then acc + 1 else acc) 0 lines in
394
-
let* () = Lwt_io.write Lwt_io.stdout (Fmt.str "Upload results for %s: %d successful, %d failed out of %d total\n"
395
-
name successes failures (List.length documents)) in
396
-
if failures > 0 then
397
-
let* () = Lwt_io.write Lwt_io.stdout (Fmt.str "Failed documents in %s:\n" name) in
396
+
Printf.printf "Upload results for %s: %d successful, %d failed out of %d total\n%!"
397
+
name successes failures (List.length documents);
398
+
if failures > 0 then (
399
+
Printf.printf "Failed documents in %s:\n%!" name;
398
400
let failed_lines = List.filter (fun line -> Str.string_match (Str.regexp ".*success.*false.*") line 0) lines in
399
-
Lwt_list.iter_s (fun line -> Lwt_io.write Lwt_io.stdout (line ^ "\n")) failed_lines
400
-
else
401
-
Lwt.return_unit
402
-
| Error err ->
401
+
List.iter (fun line -> Printf.printf "%s\n%!" line) failed_lines
402
+
)
403
+
| Error err ->
403
404
let err_str = Fmt.str "%a" pp_error err in
404
-
Lwt_io.write Lwt_io.stdout (Fmt.str "Failed to upload documents to %s: %s\n" name err_str)
405
+
Printf.printf "Failed to upload documents to %s: %s\n%!" name err_str
405
406
)
406
407
| Error err ->
407
408
let err_str = Fmt.str "%a" pp_error err in
408
-
Lwt_io.write Lwt_io.stdout (Fmt.str "Failed to create collection %s: %s\n" name err_str)
409
+
Printf.printf "Failed to create collection %s: %s\n%!" name err_str
409
410
in
410
411
411
-
Lwt_list.iter_s upload_collection collections
412
+
List.iter upload_collection collections
412
413
413
-
(** TODO:claude Re-export search types from Typesense_client *)
414
-
type search_result = Typesense_client.search_result = {
414
+
(** TODO:claude Re-export search types from Typesense_cliente *)
415
+
type search_result = Typesense_cliente.search_result = {
415
416
id: string;
416
417
title: string;
417
418
content: string;
···
421
422
document: Ezjsonm.value;
422
423
}
423
424
424
-
type search_response = Typesense_client.search_response = {
425
+
type search_response = Typesense_cliente.search_response = {
425
426
hits: search_result list;
426
427
total: int;
427
428
query_time: float;
···
429
430
430
431
(** TODO:claude Convert bushel config to client config *)
431
432
let to_client_config (config : config) =
432
-
Typesense_client.{ endpoint = config.endpoint; api_key = config.api_key }
433
+
Typesense_cliente.{ endpoint = config.endpoint; api_key = config.api_key }
433
434
434
435
(** TODO:claude Search a single collection *)
435
-
let search_collection (config : config) collection_name query ?(limit=10) ?(offset=0) () =
436
+
let search_collection ~sw ~env (config : config) collection_name query ?(limit=10) ?(offset=0) () =
436
437
let client_config = to_client_config config in
437
-
let* result = Typesense_client.search_collection client_config collection_name query ~limit ~offset () in
438
+
let result = Typesense_cliente.search_collection ~sw ~env client_config collection_name query ~limit ~offset () in
438
439
match result with
439
-
| Ok response -> Lwt.return_ok response
440
-
| Error (Typesense_client.Http_error (code, msg)) -> Lwt.return_error (Http_error (code, msg))
441
-
| Error (Typesense_client.Json_error msg) -> Lwt.return_error (Json_error msg)
442
-
| Error (Typesense_client.Connection_error msg) -> Lwt.return_error (Connection_error msg)
440
+
| Ok response -> Ok response
441
+
| Error (Typesense_cliente.Http_error (code, msg)) -> Error (Http_error (code, msg))
442
+
| Error (Typesense_cliente.Json_error msg) -> Error (Json_error msg)
443
+
| Error (Typesense_cliente.Connection_error msg) -> Error (Connection_error msg)
443
444
444
445
(** TODO:claude Search across all collections - use client multisearch *)
445
-
let search_all (config : config) query ?(limit=10) ?(offset=0) () =
446
+
let search_all ~sw ~env (config : config) query ?(limit=10) ?(offset=0) () =
446
447
let client_config = to_client_config config in
447
-
let* result = Typesense_client.multisearch client_config query ~limit:50 () in
448
+
let result = Typesense_cliente.multisearch ~sw ~env client_config query ~limit:50 () in
448
449
match result with
449
450
| Ok multisearch_resp ->
450
-
let combined_response = Typesense_client.combine_multisearch_results multisearch_resp ~limit ~offset () in
451
-
Lwt.return_ok combined_response
452
-
| Error (Typesense_client.Http_error (code, msg)) -> Lwt.return_error (Http_error (code, msg))
453
-
| Error (Typesense_client.Json_error msg) -> Lwt.return_error (Json_error msg)
454
-
| Error (Typesense_client.Connection_error msg) -> Lwt.return_error (Connection_error msg)
451
+
let combined_response = Typesense_cliente.combine_multisearch_results multisearch_resp ~limit ~offset () in
452
+
Ok combined_response
453
+
| Error (Typesense_cliente.Http_error (code, msg)) -> Error (Http_error (code, msg))
454
+
| Error (Typesense_cliente.Json_error msg) -> Error (Json_error msg)
455
+
| Error (Typesense_cliente.Connection_error msg) -> Error (Connection_error msg)
455
456
456
457
(** TODO:claude List all collections *)
457
-
let list_collections (config : config) =
458
+
let list_collections ~sw ~env (config : config) =
458
459
let client_config = to_client_config config in
459
-
let* result = Typesense_client.list_collections client_config in
460
+
let result = Typesense_cliente.list_collections ~sw ~env client_config in
460
461
match result with
461
-
| Ok collections -> Lwt.return_ok collections
462
-
| Error (Typesense_client.Http_error (code, msg)) -> Lwt.return_error (Http_error (code, msg))
463
-
| Error (Typesense_client.Json_error msg) -> Lwt.return_error (Json_error msg)
464
-
| Error (Typesense_client.Connection_error msg) -> Lwt.return_error (Connection_error msg)
462
+
| Ok collections -> Ok collections
463
+
| Error (Typesense_cliente.Http_error (code, msg)) -> Error (Http_error (code, msg))
464
+
| Error (Typesense_cliente.Json_error msg) -> Error (Json_error msg)
465
+
| Error (Typesense_cliente.Connection_error msg) -> Error (Connection_error msg)
465
466
466
-
(** TODO:claude Re-export multisearch types from Typesense_client *)
467
-
type multisearch_response = Typesense_client.multisearch_response = {
467
+
(** TODO:claude Re-export multisearch types from Typesense_cliente *)
468
+
type multisearch_response = Typesense_cliente.multisearch_response = {
468
469
results: search_response list;
469
470
}
470
471
471
472
(** TODO:claude Perform multisearch across all collections *)
472
-
let multisearch (config : config) query ?(limit=10) () =
473
+
let multisearch ~sw ~env (config : config) query ?(limit=10) () =
473
474
let client_config = to_client_config config in
474
-
let* result = Typesense_client.multisearch client_config query ~limit () in
475
+
let result = Typesense_cliente.multisearch ~sw ~env client_config query ~limit () in
475
476
match result with
476
-
| Ok multisearch_resp -> Lwt.return_ok multisearch_resp
477
-
| Error (Typesense_client.Http_error (code, msg)) -> Lwt.return_error (Http_error (code, msg))
478
-
| Error (Typesense_client.Json_error msg) -> Lwt.return_error (Json_error msg)
479
-
| Error (Typesense_client.Connection_error msg) -> Lwt.return_error (Connection_error msg)
477
+
| Ok multisearch_resp -> Ok multisearch_resp
478
+
| Error (Typesense_cliente.Http_error (code, msg)) -> Error (Http_error (code, msg))
479
+
| Error (Typesense_cliente.Json_error msg) -> Error (Json_error msg)
480
+
| Error (Typesense_cliente.Connection_error msg) -> Error (Connection_error msg)
480
481
481
482
(** TODO:claude Combine multisearch results into single result set *)
482
483
let combine_multisearch_results (multisearch_resp : multisearch_response) ?(limit=10) ?(offset=0) () =
483
-
Typesense_client.combine_multisearch_results multisearch_resp ~limit ~offset ()
484
+
Typesense_cliente.combine_multisearch_results multisearch_resp ~limit ~offset ()
484
485
485
486
(** TODO:claude Load configuration from files *)
486
487
let load_config_from_files () =
···
514
515
515
516
{ endpoint; api_key; openai_key }
516
517
517
-
(** TODO:claude Re-export pretty printer from Typesense_client *)
518
-
let pp_search_result_oneline = Typesense_client.pp_search_result_oneline
518
+
(** TODO:claude Re-export pretty printer from Typesense_cliente *)
519
+
let pp_search_result_oneline = Typesense_cliente.pp_search_result_oneline
+73
-17
stack/bushel/lib/typesense.mli
+73
-17
stack/bushel/lib/typesense.mli
···
1
1
(** Typesense API client for Bushel
2
-
2
+
3
3
This module provides an OCaml client for the Typesense search engine API.
4
4
It handles collection management and document indexing for all Bushel object
5
5
types including contacts, papers, projects, news, videos, notes, and ideas.
6
-
6
+
7
7
Example usage:
8
8
{[
9
-
let config = { endpoint = "https://search.example.com"; api_key = "xyz123" } in
10
-
Lwt_main.run (Typesense.upload_all config "/path/to/bushel/data")
9
+
let config = { endpoint = "https://search.example.com"; api_key = "xyz123"; openai_key = "sk-..." } in
10
+
Eio_main.run (fun env ->
11
+
Eio.Switch.run (fun sw ->
12
+
Typesense.upload_all ~sw ~env config entries))
11
13
]}
12
-
14
+
13
15
TODO:claude *)
14
16
15
17
(** Configuration for connecting to a Typesense server *)
···
20
22
}
21
23
22
24
(** Possible errors that can occur during Typesense operations *)
23
-
type error =
25
+
type error =
24
26
| Http_error of int * string (** HTTP error with status code and message *)
25
27
| Json_error of string (** JSON parsing or encoding error *)
26
28
| Connection_error of string (** Network connection error *)
···
28
30
(** Pretty-printer for error types *)
29
31
val pp_error : Format.formatter -> error -> unit
30
32
31
-
(** Create a collection with the given schema.
33
+
(** Create a collection with the given schema.
32
34
The schema should follow Typesense's collection schema format.
33
35
TODO:claude *)
34
-
val create_collection : config -> Ezjsonm.value -> (string, error) result Lwt.t
36
+
val create_collection :
37
+
sw:Eio.Switch.t ->
38
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
39
+
config ->
40
+
Ezjsonm.value ->
41
+
(string, error) result
35
42
36
-
(** Check if a collection exists by name.
43
+
(** Check if a collection exists by name.
37
44
Returns true if the collection exists, false otherwise.
38
45
TODO:claude *)
39
-
val collection_exists : config -> string -> bool Lwt.t
46
+
val collection_exists :
47
+
sw:Eio.Switch.t ->
48
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
49
+
config ->
50
+
string ->
51
+
bool
40
52
41
53
(** Delete a collection by name.
42
54
TODO:claude *)
43
-
val delete_collection : config -> string -> (string, error) result Lwt.t
55
+
val delete_collection :
56
+
sw:Eio.Switch.t ->
57
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
58
+
config ->
59
+
string ->
60
+
(string, error) result
44
61
45
62
(** Upload documents to a collection in batch using JSONL format.
46
63
More efficient than uploading documents one by one.
47
64
TODO:claude *)
48
-
val upload_documents : config -> string -> Ezjsonm.value list -> (string, error) result Lwt.t
65
+
val upload_documents :
66
+
sw:Eio.Switch.t ->
67
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
68
+
config ->
69
+
string ->
70
+
Ezjsonm.value list ->
71
+
(string, error) result
49
72
50
73
(** Upload all bushel objects to Typesense.
51
74
This function will:
···
54
77
- Upload all documents in batches
55
78
- Report progress to stdout
56
79
TODO:claude *)
57
-
val upload_all : config -> Entry.t -> unit Lwt.t
80
+
val upload_all :
81
+
sw:Eio.Switch.t ->
82
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
83
+
config ->
84
+
Entry.t ->
85
+
unit
58
86
59
87
(** Search result structure containing document information and relevance score *)
60
88
type search_result = {
···
76
104
77
105
(** Search a specific collection.
78
106
TODO:claude *)
79
-
val search_collection : config -> string -> string -> ?limit:int -> ?offset:int -> unit -> (search_response, error) result Lwt.t
107
+
val search_collection :
108
+
sw:Eio.Switch.t ->
109
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
110
+
config ->
111
+
string ->
112
+
string ->
113
+
?limit:int ->
114
+
?offset:int ->
115
+
unit ->
116
+
(search_response, error) result
80
117
81
118
(** Search across all bushel collections.
82
119
Results are sorted by relevance score and paginated.
83
120
TODO:claude *)
84
-
val search_all : config -> string -> ?limit:int -> ?offset:int -> unit -> (search_response, error) result Lwt.t
121
+
val search_all :
122
+
sw:Eio.Switch.t ->
123
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
124
+
config ->
125
+
string ->
126
+
?limit:int ->
127
+
?offset:int ->
128
+
unit ->
129
+
(search_response, error) result
85
130
86
131
(** Multisearch response containing results from multiple collections *)
87
132
type multisearch_response = {
···
91
136
(** Perform multisearch across all collections using Typesense's multi_search endpoint.
92
137
More efficient than individual searches as it's done in a single request.
93
138
TODO:claude *)
94
-
val multisearch : config -> string -> ?limit:int -> unit -> (multisearch_response, error) result Lwt.t
139
+
val multisearch :
140
+
sw:Eio.Switch.t ->
141
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
142
+
config ->
143
+
string ->
144
+
?limit:int ->
145
+
unit ->
146
+
(multisearch_response, error) result
95
147
96
148
(** Combine multisearch results into a single result set.
97
149
Results are sorted by relevance score and paginated.
···
101
153
(** List all collections with document counts.
102
154
Returns a list of (collection_name, document_count) pairs.
103
155
TODO:claude *)
104
-
val list_collections : config -> ((string * int) list, error) result Lwt.t
156
+
val list_collections :
157
+
sw:Eio.Switch.t ->
158
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
159
+
config ->
160
+
((string * int) list, error) result
105
161
106
162
(** Load configuration from .typesense-url and .typesense-api files.
107
163
Falls back to environment variables and defaults.
-34
stack/bushel/peertube.opam
-34
stack/bushel/peertube.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "PeerTube API client"
4
-
description: "Client for interacting with PeerTube instances"
5
-
maintainer: ["anil@recoil.org"]
6
-
authors: ["Anil Madhavapeddy"]
7
-
license: "ISC"
8
-
homepage: "https://github.com/avsm/bushel"
9
-
bug-reports: "https://github.com/avsm/bushel/issues"
10
-
depends: [
11
-
"dune" {>= "3.17"}
12
-
"ocaml" {>= "5.2.0"}
13
-
"ezjsonm"
14
-
"lwt"
15
-
"cohttp-lwt-unix"
16
-
"ptime"
17
-
"fmt"
18
-
"odoc" {with-doc}
19
-
]
20
-
build: [
21
-
["dune" "subst"] {dev}
22
-
[
23
-
"dune"
24
-
"build"
25
-
"-p"
26
-
name
27
-
"-j"
28
-
jobs
29
-
"@install"
30
-
"@runtest" {with-test}
31
-
"@doc" {with-doc}
32
-
]
33
-
]
34
-
dev-repo: "git+https://github.com/avsm/bushel.git"
-4
stack/bushel/peertube/dune
-4
stack/bushel/peertube/dune
+57
-63
stack/bushel/peertube/peertube.ml
stack/peertubee/peertubee.ml
+57
-63
stack/bushel/peertube/peertube.ml
stack/peertubee/peertubee.ml
···
1
-
(** PeerTube API client implementation
2
-
TODO:claude *)
3
-
4
-
open Lwt.Infix
1
+
(** PeerTube API client implementation (Eio version) *)
5
2
6
3
module J = Ezjsonm
7
4
···
29
26
let parse_date str =
30
27
match Ptime.of_rfc3339 str with
31
28
| Ok (date, _, _) -> date
32
-
| Error _ ->
29
+
| Error _ ->
33
30
Fmt.epr "Warning: could not parse date '%s'\n" str;
34
31
(* Default to epoch time *)
35
32
let span_opt = Ptime.Span.of_d_ps (0, 0L) in
···
47
44
48
45
(** Extract a string list field from JSON, returns empty list if not present *)
49
46
let get_string_list json path =
50
-
try
47
+
try
51
48
let tags_json = J.find json path in
52
49
J.get_list J.get_string tags_json
53
50
with _ -> []
···
60
57
let description = get_string_opt json ["description"] in
61
58
let url = J.find json ["url"] |> J.get_string in
62
59
let embed_path = J.find json ["embedPath"] |> J.get_string in
63
-
60
+
64
61
(* Parse dates *)
65
-
let published_at =
66
-
J.find json ["publishedAt"] |> J.get_string |> parse_date
62
+
let published_at =
63
+
J.find json ["publishedAt"] |> J.get_string |> parse_date
67
64
in
68
-
65
+
69
66
let originally_published_at =
70
67
match get_string_opt json ["originallyPublishedAt"] with
71
68
| Some date -> Some (parse_date date)
72
69
| None -> None
73
70
in
74
-
71
+
75
72
let thumbnail_path = get_string_opt json ["thumbnailPath"] in
76
73
let tags = get_string_list json ["tags"] in
77
-
78
-
{ id; uuid; name; description; url; embed_path;
79
-
published_at; originally_published_at;
74
+
75
+
{ id; uuid; name; description; url; embed_path;
76
+
published_at; originally_published_at;
80
77
thumbnail_path; tags }
81
78
82
79
(** Parse a PeerTube video response *)
···
91
88
@param start Starting index for pagination (0-based)
92
89
@param base_url Base URL of the PeerTube instance
93
90
@param channel Channel name to fetch videos from
94
-
@return A Lwt promise with the video response
95
-
TODO:claude *)
96
-
let fetch_channel_videos ?(count=20) ?(start=0) base_url channel =
97
-
let open Cohttp_lwt_unix in
98
-
let url = Printf.sprintf "%s/api/v1/video-channels/%s/videos?count=%d&start=%d"
91
+
@return The video response *)
92
+
let fetch_channel_videos ~sw ~env ?(count=20) ?(start=0) base_url channel =
93
+
let url = Printf.sprintf "%s/api/v1/video-channels/%s/videos?count=%d&start=%d"
99
94
base_url channel count start in
100
-
Client.get (Uri.of_string url) >>= fun (resp, body) ->
101
-
if resp.status = `OK then
102
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
103
-
let json = J.from_string body_str in
104
-
Lwt.return (parse_video_response json)
95
+
let response = Requests.One.get ~sw ~clock:(Eio.Stdenv.clock env) ~net:(Eio.Stdenv.net env) url in
96
+
let status_code = Requests.Response.status_code response in
97
+
if status_code = 200 then
98
+
let s = Requests.Response.body response |> Eio.Flow.read_all in
99
+
let json = J.from_string s in
100
+
parse_video_response json
105
101
else
106
-
let status_code = Cohttp.Code.code_of_status resp.status in
107
-
Lwt.fail_with (Fmt.str "HTTP error: %d" status_code)
102
+
failwith (Fmt.str "HTTP error: %d" status_code)
108
103
109
104
(** Fetch all videos from a PeerTube instance channel using pagination
110
105
@param page_size Number of videos to fetch per page
111
106
@param max_pages Maximum number of pages to fetch (None for all pages)
112
107
@param base_url Base URL of the PeerTube instance
113
108
@param channel Channel name to fetch videos from
114
-
@return A Lwt promise with all videos combined
115
-
TODO:claude *)
116
-
let fetch_all_channel_videos ?(page_size=20) ?max_pages base_url channel =
109
+
@return All videos combined *)
110
+
let fetch_all_channel_videos ~sw ~env ?(page_size=20) ?max_pages base_url channel =
117
111
let rec fetch_pages start acc _total_count =
118
-
fetch_channel_videos ~count:page_size ~start base_url channel >>= fun response ->
112
+
let response = fetch_channel_videos ~sw ~env ~count:page_size ~start base_url channel in
119
113
let all_videos = acc @ response.data in
120
-
114
+
121
115
(* Determine if we need to fetch more pages *)
122
116
let fetched_count = start + List.length response.data in
123
117
let more_available = fetched_count < response.total in
···
125
119
| None -> true
126
120
| Some max -> (start / page_size) + 1 < max
127
121
in
128
-
122
+
129
123
if more_available && under_max_pages then
130
124
fetch_pages fetched_count all_videos response.total
131
125
else
132
-
Lwt.return all_videos
126
+
all_videos
133
127
in
134
128
fetch_pages 0 [] 0
135
129
136
130
(** Fetch detailed information for a single video by UUID
137
131
@param base_url Base URL of the PeerTube instance
138
132
@param uuid UUID of the video to fetch
139
-
@return A Lwt promise with the complete video details
140
-
TODO:claude *)
141
-
let fetch_video_details base_url uuid =
142
-
let open Cohttp_lwt_unix in
133
+
@return The complete video details *)
134
+
let fetch_video_details ~sw ~env base_url uuid =
143
135
let url = Printf.sprintf "%s/api/v1/videos/%s" base_url uuid in
144
-
Client.get (Uri.of_string url) >>= fun (resp, body) ->
145
-
if resp.status = `OK then
146
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
147
-
let json = J.from_string body_str in
136
+
let response = Requests.One.get ~sw ~clock:(Eio.Stdenv.clock env) ~net:(Eio.Stdenv.net env) url in
137
+
let status_code = Requests.Response.status_code response in
138
+
if status_code = 200 then
139
+
let s = Requests.Response.body response |> Eio.Flow.read_all in
140
+
let json = J.from_string s in
148
141
(* Parse the single video details *)
149
-
Lwt.return (parse_video json)
142
+
parse_video json
150
143
else
151
-
let status_code = Cohttp.Code.code_of_status resp.status in
152
-
Lwt.fail_with (Fmt.str "HTTP error: %d" status_code)
144
+
failwith (Fmt.str "HTTP error: %d" status_code)
153
145
154
146
(** Convert a PeerTube video to Bushel.Video.t compatible structure *)
155
147
let to_bushel_video video =
···
167
159
@param base_url Base URL of the PeerTube instance
168
160
@param video The video to download the thumbnail for
169
161
@param output_path Path where to save the thumbnail
170
-
@return A Lwt promise with unit on success *)
171
-
let download_thumbnail base_url video output_path =
162
+
@return Ok () on success or Error with message *)
163
+
let download_thumbnail ~sw ~env base_url video output_path =
172
164
match thumbnail_url base_url video with
173
165
| None ->
174
-
Lwt.return (Error (`Msg (Printf.sprintf "No thumbnail available for video %s" video.uuid)))
166
+
Error (`Msg (Printf.sprintf "No thumbnail available for video %s" video.uuid))
175
167
| Some url ->
176
-
let open Cohttp_lwt_unix in
177
-
Client.get (Uri.of_string url) >>= fun (resp, body) ->
178
-
if resp.status = `OK then
179
-
Cohttp_lwt.Body.to_string body >>= fun body_str ->
180
-
Lwt.catch
181
-
(fun () ->
182
-
let oc = open_out_bin output_path in
183
-
output_string oc body_str;
184
-
close_out oc;
185
-
Lwt.return (Ok ()))
186
-
(fun exn ->
187
-
Lwt.return (Error (`Msg (Printf.sprintf "Failed to write thumbnail: %s"
188
-
(Printexc.to_string exn)))))
189
-
else
190
-
let status_code = Cohttp.Code.code_of_status resp.status in
191
-
Lwt.return (Error (`Msg (Printf.sprintf "HTTP error downloading thumbnail: %d" status_code)))
168
+
try
169
+
let response = Requests.One.get ~sw ~clock:(Eio.Stdenv.clock env) ~net:(Eio.Stdenv.net env) url in
170
+
let status_code = Requests.Response.status_code response in
171
+
if status_code = 200 then
172
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
173
+
try
174
+
let fs = Eio.Stdenv.fs env in
175
+
let output_eio_path = Eio.Path.(fs / output_path) in
176
+
Eio.Path.save ~create:(`Or_truncate 0o644) output_eio_path body_str;
177
+
Ok ()
178
+
with exn ->
179
+
Error (`Msg (Printf.sprintf "Failed to write thumbnail: %s"
180
+
(Printexc.to_string exn)))
181
+
else
182
+
Error (`Msg (Printf.sprintf "HTTP error downloading thumbnail: %d" status_code))
183
+
with exn ->
184
+
Error (`Msg (Printf.sprintf "Failed to download thumbnail: %s"
185
+
(Printexc.to_string exn)))
+13
-6
stack/bushel/peertube/peertube.mli
stack/peertubee/peertubee.mli
+13
-6
stack/bushel/peertube/peertube.mli
stack/peertubee/peertubee.mli
···
1
-
(** PeerTube API client interface
2
-
TODO:claude *)
1
+
(** PeerTube API client interface (Eio version) *)
3
2
4
3
(** Type representing a PeerTube video *)
5
4
type video = {
···
28
27
val parse_video_response : Ezjsonm.value -> video_response
29
28
30
29
(** Fetch videos from a PeerTube instance channel with pagination support
30
+
@param sw Eio switch for resource management
31
+
@param env Eio environment for network and clock access
31
32
@param count Number of videos to fetch per page (default: 20)
32
33
@param start Starting index for pagination (0-based) (default: 0)
33
34
@param base_url Base URL of the PeerTube instance
34
35
@param channel Channel name to fetch videos from *)
35
-
val fetch_channel_videos : ?count:int -> ?start:int -> string -> string -> video_response Lwt.t
36
+
val fetch_channel_videos : sw:Eio.Switch.t -> env:< clock : 'a Eio.Time.clock; net : 'b Eio.Net.t; .. > -> ?count:int -> ?start:int -> string -> string -> video_response
36
37
37
38
(** Fetch all videos from a PeerTube instance channel using pagination
39
+
@param sw Eio switch for resource management
40
+
@param env Eio environment for network and clock access
38
41
@param page_size Number of videos to fetch per page (default: 20)
39
42
@param max_pages Maximum number of pages to fetch (None for all pages)
40
43
@param base_url Base URL of the PeerTube instance
41
44
@param channel Channel name to fetch videos from *)
42
-
val fetch_all_channel_videos : ?page_size:int -> ?max_pages:int -> string -> string -> video list Lwt.t
45
+
val fetch_all_channel_videos : sw:Eio.Switch.t -> env:< clock : 'a Eio.Time.clock; net : 'b Eio.Net.t; .. > -> ?page_size:int -> ?max_pages:int -> string -> string -> video list
43
46
44
47
(** Fetch detailed information for a single video by UUID
48
+
@param sw Eio switch for resource management
49
+
@param env Eio environment for network and clock access
45
50
@param base_url Base URL of the PeerTube instance
46
51
@param uuid UUID of the video to fetch *)
47
-
val fetch_video_details : string -> string -> video Lwt.t
52
+
val fetch_video_details : sw:Eio.Switch.t -> env:< clock : 'a Eio.Time.clock; net : 'b Eio.Net.t; .. > -> string -> string -> video
48
53
49
54
(** Convert a PeerTube video to Bushel.Video.t compatible structure
50
55
Returns (description, published_date, title, url, uuid, slug) *)
···
56
61
val thumbnail_url : string -> video -> string option
57
62
58
63
(** Download a thumbnail to a file
64
+
@param sw Eio switch for resource management
65
+
@param env Eio environment for network and filesystem access
59
66
@param base_url Base URL of the PeerTube instance
60
67
@param video The video to download the thumbnail for
61
68
@param output_path Path where to save the thumbnail *)
62
-
val download_thumbnail : string -> video -> string -> (unit, [> `Msg of string]) result Lwt.t
69
+
val download_thumbnail : sw:Eio.Switch.t -> env:< clock : 'a Eio.Time.clock; net : 'b Eio.Net.t; fs : 'c Eio.Path.t; .. > -> string -> video -> string -> (unit, [> `Msg of string]) result
-36
stack/bushel/typesense-client.opam
-36
stack/bushel/typesense-client.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "Standalone Typesense client for OCaml"
4
-
description:
5
-
"A standalone Typesense client that can be compiled to JavaScript"
6
-
maintainer: ["anil@recoil.org"]
7
-
authors: ["Anil Madhavapeddy"]
8
-
license: "ISC"
9
-
homepage: "https://github.com/avsm/bushel"
10
-
bug-reports: "https://github.com/avsm/bushel/issues"
11
-
depends: [
12
-
"dune" {>= "3.17"}
13
-
"ocaml" {>= "5.2.0"}
14
-
"ezjsonm"
15
-
"lwt"
16
-
"cohttp-lwt-unix"
17
-
"ptime"
18
-
"fmt"
19
-
"uri"
20
-
"odoc" {with-doc}
21
-
]
22
-
build: [
23
-
["dune" "subst"] {dev}
24
-
[
25
-
"dune"
26
-
"build"
27
-
"-p"
28
-
name
29
-
"-j"
30
-
jobs
31
-
"@install"
32
-
"@runtest" {with-test}
33
-
"@doc" {with-doc}
34
-
]
35
-
]
36
-
dev-repo: "git+https://github.com/avsm/bushel.git"
-5
stack/bushel/typesense-client/dune
-5
stack/bushel/typesense-client/dune
+89
-87
stack/bushel/typesense-client/typesense_client.ml
stack/typesense-cliente/typesense_cliente.ml
+89
-87
stack/bushel/typesense-client/typesense_client.ml
stack/typesense-cliente/typesense_cliente.ml
···
1
-
open Lwt.Syntax
2
-
open Cohttp_lwt_unix
3
-
4
-
(** TODO:claude Standalone Typesense client for OCaml *)
1
+
(** Typesense client for OCaml using Eio and Requests *)
5
2
6
3
(** Configuration for Typesense client *)
7
4
type config = {
···
10
7
}
11
8
12
9
(** Error types for Typesense operations *)
13
-
type error =
10
+
type error =
14
11
| Http_error of int * string
15
12
| Json_error of string
16
13
| Connection_error of string
···
20
17
| Json_error msg -> Fmt.pf fmt "JSON error: %s" msg
21
18
| Connection_error msg -> Fmt.pf fmt "Connection error: %s" msg
22
19
23
-
(** TODO:claude Create authentication headers for Typesense API *)
20
+
(** Create authentication headers for Typesense API *)
24
21
let auth_headers api_key =
25
-
Cohttp.Header.of_list [
26
-
("X-TYPESENSE-API-KEY", api_key);
27
-
("Content-Type", "application/json");
28
-
]
22
+
Requests.Headers.empty
23
+
|> Requests.Headers.set "X-TYPESENSE-API-KEY" api_key
24
+
|> Requests.Headers.set "Content-Type" "application/json"
29
25
30
-
(** TODO:claude Make HTTP request to Typesense API *)
31
-
let make_request ?(meth=`GET) ?(body="") config path =
26
+
(** Make HTTP request to Typesense API *)
27
+
let make_request ~sw ~env ?(meth=`GET) ?(body="") config path =
32
28
let uri = Uri.of_string (config.endpoint ^ path) in
33
29
let headers = auth_headers config.api_key in
34
-
let body = if body = "" then `Empty else `String body in
35
-
Lwt.catch (fun () ->
36
-
let* resp, body = Client.call ~headers ~body meth uri in
37
-
let status = Cohttp.Code.code_of_status (Response.status resp) in
38
-
let* body_str = Cohttp_lwt.Body.to_string body in
30
+
let body = if body = "" then None else Some (Requests.Body.of_string Requests.Mime.json body) in
31
+
32
+
try
33
+
let response = Requests.One.request ~sw ~clock:env#clock ~net:env#net
34
+
?body
35
+
~headers
36
+
~method_:meth
37
+
(Uri.to_string uri)
38
+
in
39
+
40
+
let status = Requests.Response.status_code response in
41
+
let body_flow = Requests.Response.body response in
42
+
let body_str = Eio.Flow.read_all body_flow in
43
+
39
44
if status >= 200 && status < 300 then
40
-
Lwt.return_ok body_str
45
+
Ok body_str
41
46
else
42
-
Lwt.return_error (Http_error (status, body_str))
43
-
) (fun exn ->
44
-
Lwt.return_error (Connection_error (Printexc.to_string exn))
45
-
)
47
+
Error (Http_error (status, body_str))
48
+
with exn ->
49
+
Error (Connection_error (Printexc.to_string exn))
46
50
47
-
(** TODO:claude Search result types *)
51
+
(** Search result types *)
48
52
type search_result = {
49
53
id: string;
50
54
title: string;
···
61
65
query_time: float;
62
66
}
63
67
64
-
(** TODO:claude Parse search result from JSON *)
68
+
(** Parse search result from JSON *)
65
69
let parse_search_result collection json =
66
70
let open Ezjsonm in
67
71
let document = get_dict json |> List.assoc "document" in
68
72
let highlights = try get_dict json |> List.assoc "highlights" with _ -> `A [] in
69
73
let score = try get_dict json |> List.assoc "text_match" |> get_float with _ -> 0.0 in
70
-
74
+
71
75
let id = get_dict document |> List.assoc "id" |> get_string in
72
76
let title = try get_dict document |> List.assoc "title" |> get_string with _ -> "" in
73
77
let content = try
···
81
85
| "contacts" -> get_dict document |> List.assoc "name" |> get_string
82
86
| _ -> ""
83
87
with _ -> "" in
84
-
88
+
85
89
let parse_highlights highlights =
86
90
try
87
91
get_list (fun h ->
···
91
95
) highlights
92
96
with _ -> []
93
97
in
94
-
98
+
95
99
{ id; title; content; score; collection; highlights = parse_highlights highlights; document }
96
100
97
-
(** TODO:claude Parse search response from JSON *)
101
+
(** Parse search response from JSON *)
98
102
let parse_search_response collection json =
99
103
let open Ezjsonm in
100
104
let hits = get_dict json |> List.assoc "hits" |> get_list (parse_search_result collection) in
···
102
106
let query_time = get_dict json |> List.assoc "search_time_ms" |> get_float in
103
107
{ hits; total; query_time }
104
108
105
-
(** TODO:claude Search a single collection *)
106
-
let search_collection config collection_name query ?(limit=10) ?(offset=0) () =
109
+
(** Search a single collection *)
110
+
let search_collection ~sw ~env config collection_name query ?(limit=10) ?(offset=0) () =
107
111
let escaped_query = Uri.pct_encode query in
108
112
let query_fields = match collection_name with
109
113
| "papers" -> "title,abstract,authors"
···
117
121
in
118
122
let path = Printf.sprintf "/collections/%s/documents/search?q=%s&query_by=%s&per_page=%d&page=%d&highlight_full_fields=%s"
119
123
collection_name escaped_query query_fields limit ((offset / limit) + 1) query_fields in
120
-
let* result = make_request config path in
121
-
match result with
124
+
125
+
match make_request ~sw ~env config path with
122
126
| Ok response_str ->
123
127
(try
124
128
let json = Ezjsonm.from_string response_str in
125
129
let search_response = parse_search_response collection_name json in
126
-
Lwt.return_ok search_response
130
+
Ok search_response
127
131
with exn ->
128
-
Lwt.return_error (Json_error (Printexc.to_string exn)))
129
-
| Error err -> Lwt.return_error err
132
+
Error (Json_error (Printexc.to_string exn)))
133
+
| Error err -> Error err
130
134
131
-
(** TODO:claude Helper function to drop n elements from list *)
135
+
(** Helper function to drop n elements from list *)
132
136
let rec drop n lst =
133
137
if n <= 0 then lst
134
138
else match lst with
135
139
| [] -> []
136
140
| _ :: tl -> drop (n - 1) tl
137
141
138
-
(** TODO:claude Helper function to take n elements from list *)
142
+
(** Helper function to take n elements from list *)
139
143
let rec take n lst =
140
144
if n <= 0 then []
141
145
else match lst with
142
146
| [] -> []
143
147
| hd :: tl -> hd :: take (n - 1) tl
144
148
145
-
(** TODO:claude Multisearch result types *)
149
+
(** Multisearch result types *)
146
150
type multisearch_response = {
147
151
results: search_response list;
148
152
}
149
153
150
-
(** TODO:claude Parse multisearch response from JSON *)
154
+
(** Parse multisearch response from JSON *)
151
155
let parse_multisearch_response json =
152
156
let open Ezjsonm in
153
157
let results_json = get_dict json |> List.assoc "results" |> get_list (fun r -> r) in
154
158
let results = List.mapi (fun i result_json ->
155
159
let collection_name = match i with
156
160
| 0 -> "contacts"
157
-
| 1 -> "news"
161
+
| 1 -> "news"
158
162
| 2 -> "notes"
159
163
| 3 -> "papers"
160
164
| 4 -> "projects"
···
166
170
) results_json in
167
171
{ results }
168
172
169
-
(** TODO:claude Perform multisearch across all collections *)
170
-
let multisearch config query ?(limit=10) () =
173
+
(** Perform multisearch across all collections *)
174
+
let multisearch ~sw ~env config query ?(limit=10) () =
171
175
let collections = ["contacts"; "news"; "notes"; "papers"; "projects"; "ideas"; "videos"] in
172
176
let query_by_collection = [
173
177
("contacts", "name,names,email,handle,github,twitter,url");
···
178
182
("ideas", "title,description,level,status,project,supervisors,tags");
179
183
("videos", "title,description,channel,platform,tags");
180
184
] in
181
-
185
+
182
186
let searches = List.map (fun collection ->
183
187
let query_by = List.assoc collection query_by_collection in
184
188
Ezjsonm.dict [
···
189
193
("per_page", Ezjsonm.int limit);
190
194
]
191
195
) collections in
192
-
196
+
193
197
let body = Ezjsonm.dict [("searches", Ezjsonm.list (fun x -> x) searches)] |> Ezjsonm.value_to_string in
194
-
let* result = make_request ~meth:`POST ~body config "/multi_search" in
195
-
196
-
match result with
198
+
199
+
match make_request ~sw ~env ~meth:`POST ~body config "/multi_search" with
197
200
| Ok response_str ->
198
201
(try
199
202
let json = Ezjsonm.from_string response_str in
200
203
let multisearch_resp = parse_multisearch_response json in
201
-
Lwt.return_ok multisearch_resp
204
+
Ok multisearch_resp
202
205
with exn ->
203
-
Lwt.return_error (Json_error (Printexc.to_string exn)))
204
-
| Error err -> Lwt.return_error err
206
+
Error (Json_error (Printexc.to_string exn)))
207
+
| Error err -> Error err
205
208
206
-
(** TODO:claude Combine multisearch results into single result set *)
209
+
(** Combine multisearch results into single result set *)
207
210
let combine_multisearch_results (multisearch_resp : multisearch_response) ?(limit=10) ?(offset=0) () =
208
211
(* Collect all hits from all collections *)
209
212
let all_hits = List.fold_left (fun acc response ->
210
213
response.hits @ acc
211
214
) [] multisearch_resp.results in
212
-
215
+
213
216
(* Sort by score descending *)
214
217
let sorted_hits = List.sort (fun a b -> Float.compare b.score a.score) all_hits in
215
-
218
+
216
219
(* Apply offset and limit *)
217
220
let dropped_hits = drop offset sorted_hits in
218
221
let final_hits = take limit dropped_hits in
219
-
222
+
220
223
(* Calculate totals *)
221
224
let total = List.fold_left (fun acc response -> acc + response.total) 0 multisearch_resp.results in
222
225
let query_time = List.fold_left (fun acc response -> acc +. response.query_time) 0.0 multisearch_resp.results in
223
-
226
+
224
227
{ hits = final_hits; total; query_time }
225
228
226
-
(** TODO:claude List all collections *)
227
-
let list_collections config =
228
-
let* result = make_request config "/collections" in
229
-
match result with
229
+
(** List all collections *)
230
+
let list_collections ~sw ~env config =
231
+
match make_request ~sw ~env config "/collections" with
230
232
| Ok response_str ->
231
233
(try
232
234
let json = Ezjsonm.from_string response_str in
···
235
237
let num_docs = Ezjsonm.get_dict c |> List.assoc "num_documents" |> Ezjsonm.get_int in
236
238
(name, num_docs)
237
239
) json in
238
-
Lwt.return_ok collections
240
+
Ok collections
239
241
with exn ->
240
-
Lwt.return_error (Json_error (Printexc.to_string exn)))
241
-
| Error err -> Lwt.return_error err
242
+
Error (Json_error (Printexc.to_string exn)))
243
+
| Error err -> Error err
242
244
243
-
(** TODO:claude Pretty printer utilities *)
245
+
(** Pretty printer utilities *)
244
246
245
247
(** Extract field value from JSON document or return empty string if not found *)
246
248
let extract_field_string document field =
···
285
287
| ts when List.length ts <= 3 -> String.concat ", " ts
286
288
| ts -> Printf.sprintf "%s (+%d more)" (String.concat ", " (take 2 ts)) (List.length ts - 2)
287
289
288
-
(** TODO:claude One-line pretty printer for search results *)
290
+
(** One-line pretty printer for search results *)
289
291
let pp_search_result_oneline (result : search_result) =
290
292
let document = result.document in
291
-
293
+
292
294
match result.collection with
293
295
| "papers" ->
294
296
let authors = extract_field_string_list document "authors" in
295
297
let date = extract_field_string document "date" in
296
298
let journal = extract_field_string_list document "journal" in
297
299
let journal_str = match journal with [] -> "" | j :: _ -> Printf.sprintf " (%s)" j in
298
-
Printf.sprintf "📄 %s — %s%s %s"
299
-
result.title
300
+
Printf.sprintf "📄 %s — %s%s %s"
301
+
result.title
300
302
(format_authors authors)
301
303
journal_str
302
304
(format_date date)
303
-
305
+
304
306
| "videos" ->
305
307
let date = extract_field_string document "published_date" in
306
308
let uuid = extract_field_string document "uuid" in
···
308
310
let talk_indicator = if is_talk then "🎤" else "🎬" in
309
311
let url = extract_field_string document "url" in
310
312
let url_display = if url = "" then "" else Printf.sprintf " <%s>" url in
311
-
Printf.sprintf "%s %s — %s [%s]%s"
313
+
Printf.sprintf "%s %s — %s [%s]%s"
312
314
talk_indicator
313
-
result.title
315
+
result.title
314
316
(format_date date)
315
317
(if uuid = "" then result.id else uuid)
316
318
url_display
317
-
319
+
318
320
| "projects" ->
319
321
let start_year = extract_field_string document "start_year" in
320
322
let tags = extract_field_string_list document "tags" in
321
323
let tags_str = match tags with [] -> "" | ts -> Printf.sprintf " #%s" (format_tags ts) in
322
-
Printf.sprintf "🚀 %s — %s%s"
323
-
result.title
324
+
Printf.sprintf "🚀 %s — %s%s"
325
+
result.title
324
326
(if start_year = "" then "" else Printf.sprintf "(%s) " start_year)
325
327
tags_str
326
-
328
+
327
329
| "news" ->
328
330
let date = extract_field_string document "date" in
329
331
let url = extract_field_string document "url" in
330
332
let url_display = if url = "" then "" else Printf.sprintf " <%s>" url in
331
-
Printf.sprintf "📰 %s — %s%s"
332
-
result.title
333
+
Printf.sprintf "📰 %s — %s%s"
334
+
result.title
333
335
(format_date date)
334
336
url_display
335
-
337
+
336
338
| "notes" ->
337
339
let date = extract_field_string document "date" in
338
340
let tags = extract_field_string_list document "tags" in
339
341
let tags_str = match tags with [] -> "" | ts -> Printf.sprintf " #%s" (format_tags ts) in
340
-
Printf.sprintf "📝 %s — %s%s"
341
-
result.title
342
+
Printf.sprintf "📝 %s — %s%s"
343
+
result.title
342
344
(format_date date)
343
345
tags_str
344
-
346
+
345
347
| "ideas" ->
346
348
let project = extract_field_string document "project" in
347
349
let level = extract_field_string document "level" in
348
350
let status = extract_field_string document "status" in
349
351
let year = extract_field_string document "year" in
350
-
Printf.sprintf "💡 %s — %s%s%s %s"
351
-
result.title
352
+
Printf.sprintf "💡 %s — %s%s%s %s"
353
+
result.title
352
354
(if project = "" then "" else Printf.sprintf "[%s] " project)
353
355
(if level = "" then "" else Printf.sprintf "(%s) " level)
354
356
(if status = "" then "" else Printf.sprintf "%s " status)
355
357
year
356
-
358
+
357
359
| "contacts" ->
358
360
let names = extract_field_string_list document "names" in
359
361
let handle = extract_field_string document "handle" in
···
365
367
(if email = "" then "" else email);
366
368
(if github = "" then "" else Printf.sprintf "github:%s" github);
367
369
] |> List.filter (fun s -> s <> "") |> String.concat " " in
368
-
Printf.sprintf "👤 %s — %s"
369
-
name_str
370
+
Printf.sprintf "👤 %s — %s"
371
+
name_str
370
372
contact_info
371
-
372
-
| _ -> Printf.sprintf "[%s] %s" result.collection result.title
373
+
374
+
| _ -> Printf.sprintf "[%s] %s" result.collection result.title
-60
stack/bushel/typesense-client/typesense_client.mli
-60
stack/bushel/typesense-client/typesense_client.mli
···
1
-
(** Standalone Typesense client for OCaml *)
2
-
3
-
(** Configuration for Typesense client *)
4
-
type config = {
5
-
endpoint : string;
6
-
api_key : string;
7
-
}
8
-
9
-
(** Error types for Typesense operations *)
10
-
type error =
11
-
| Http_error of int * string
12
-
| Json_error of string
13
-
| Connection_error of string
14
-
15
-
val pp_error : Format.formatter -> error -> unit
16
-
17
-
(** Search result types *)
18
-
type search_result = {
19
-
id: string;
20
-
title: string;
21
-
content: string;
22
-
score: float;
23
-
collection: string;
24
-
highlights: (string * string list) list;
25
-
document: Ezjsonm.value; (* Store raw document for flexible field access *)
26
-
}
27
-
28
-
type search_response = {
29
-
hits: search_result list;
30
-
total: int;
31
-
query_time: float;
32
-
}
33
-
34
-
(** Multisearch result types *)
35
-
type multisearch_response = {
36
-
results: search_response list;
37
-
}
38
-
39
-
(** Search a single collection *)
40
-
val search_collection : config -> string -> string -> ?limit:int -> ?offset:int -> unit -> (search_response, error) result Lwt.t
41
-
42
-
(** Perform multisearch across all collections *)
43
-
val multisearch : config -> string -> ?limit:int -> unit -> (multisearch_response, error) result Lwt.t
44
-
45
-
(** Combine multisearch results into single result set *)
46
-
val combine_multisearch_results : multisearch_response -> ?limit:int -> ?offset:int -> unit -> search_response
47
-
48
-
(** List all collections *)
49
-
val list_collections : config -> ((string * int) list, error) result Lwt.t
50
-
51
-
(** Pretty printer utilities *)
52
-
val extract_field_string : Ezjsonm.value -> string -> string
53
-
val extract_field_string_list : Ezjsonm.value -> string -> string list
54
-
val extract_field_bool : Ezjsonm.value -> string -> bool
55
-
val format_authors : string list -> string
56
-
val format_date : string -> string
57
-
val format_tags : string list -> string
58
-
59
-
(** One-line pretty printer for search results *)
60
-
val pp_search_result_oneline : search_result -> string
+195
stack/immiche/README.md
+195
stack/immiche/README.md
···
1
+
# Immiche - Immich API Client Library
2
+
3
+
A clean Eio-based OCaml library for interacting with Immich instances, focusing on people and face recognition data.
4
+
5
+
## Overview
6
+
7
+
Immiche provides a straightforward API for interacting with Immich's people management endpoints. It uses the Requests library for HTTP operations and follows Eio patterns for concurrency and resource management.
8
+
9
+
## Features
10
+
11
+
- Fetch all people from an Immich instance
12
+
- Search for people by name
13
+
- Fetch individual person details
14
+
- Download person thumbnails
15
+
- Full Eio integration (no Lwt dependency)
16
+
- Type-safe API with result types for error handling
17
+
18
+
## API
19
+
20
+
### Types
21
+
22
+
```ocaml
23
+
(* Client type - encapsulates session with connection pooling *)
24
+
type ('clock, 'net) t
25
+
26
+
type person = {
27
+
id: string;
28
+
name: string;
29
+
birth_date: string option;
30
+
thumbnail_path: string;
31
+
is_hidden: bool;
32
+
}
33
+
34
+
type people_response = {
35
+
total: int;
36
+
visible: int;
37
+
people: person list;
38
+
}
39
+
```
40
+
41
+
### Client Creation
42
+
43
+
#### `create`
44
+
Create an Immich client with connection pooling.
45
+
46
+
```ocaml
47
+
val create :
48
+
sw:Eio.Switch.t ->
49
+
env:< clock: _ ; net: _ ; fs: _ ; .. > ->
50
+
?requests_session:('clock, 'net) Requests.t ->
51
+
base_url:string ->
52
+
api_key:string ->
53
+
unit -> ('clock, 'net) t
54
+
```
55
+
56
+
**Parameters:**
57
+
- `sw` - Eio switch for resource management
58
+
- `env` - Eio environment (provides clock, net, fs)
59
+
- `requests_session` - Optional Requests session for connection pooling. If not provided, a new session is created.
60
+
- `base_url` - Base URL of the Immich instance (e.g., "https://photos.example.com")
61
+
- `api_key` - API key for authentication
62
+
63
+
**Returns:** An Immich client configured for the specified instance
64
+
65
+
### API Functions
66
+
67
+
All API functions take a client as their first parameter. The client automatically handles:
68
+
- Connection pooling (reuses TCP connections)
69
+
- Authentication (API key set as default header)
70
+
- Base URL configuration
71
+
72
+
#### `fetch_people`
73
+
Fetch all people from an Immich instance.
74
+
75
+
```ocaml
76
+
val fetch_people : ('clock, 'net) t -> people_response
77
+
```
78
+
79
+
#### `search_person`
80
+
Search for people by name.
81
+
82
+
```ocaml
83
+
val search_person : ('clock, 'net) t -> name:string -> person list
84
+
```
85
+
86
+
#### `fetch_person`
87
+
Fetch details for a specific person.
88
+
89
+
```ocaml
90
+
val fetch_person : ('clock, 'net) t -> person_id:string -> person
91
+
```
92
+
93
+
#### `download_thumbnail`
94
+
Download a person's thumbnail image.
95
+
96
+
```ocaml
97
+
val download_thumbnail :
98
+
('clock, 'net) t ->
99
+
fs:_ Eio.Path.t ->
100
+
person_id:string ->
101
+
output_path:string ->
102
+
(unit, [> `Msg of string]) result
103
+
```
104
+
105
+
## Example Usage
106
+
107
+
### Basic Usage
108
+
109
+
```ocaml
110
+
open Eio.Std
111
+
112
+
let () =
113
+
Eio_main.run @@ fun env ->
114
+
Switch.run @@ fun sw ->
115
+
116
+
(* Create client once with connection pooling *)
117
+
let client = Immiche.create ~sw ~env
118
+
~base_url:"https://photos.example.com"
119
+
~api_key:"your-api-key" () in
120
+
121
+
(* Fetch all people - connection pooling automatic *)
122
+
let response = Immiche.fetch_people client in
123
+
Printf.printf "Total people: %d\n" response.total;
124
+
125
+
(* Search for a person - reuses connections *)
126
+
let results = Immiche.search_person client ~name:"John" in
127
+
128
+
(* Download first result's thumbnail *)
129
+
match results with
130
+
| person :: _ ->
131
+
let result = Immiche.download_thumbnail client
132
+
~fs:(Eio.Stdenv.fs env)
133
+
~person_id:person.id
134
+
~output_path:"thumbnail.jpg" in
135
+
begin match result with
136
+
| Ok () -> print_endline "Thumbnail downloaded!"
137
+
| Error (`Msg err) -> Printf.eprintf "Error: %s\n" err
138
+
end
139
+
| [] -> print_endline "No results found"
140
+
```
141
+
142
+
### Sharing Connection Pools
143
+
144
+
You can share a `Requests.t` session across multiple API clients for maximum connection reuse:
145
+
146
+
```ocaml
147
+
Eio_main.run @@ fun env ->
148
+
Switch.run @@ fun sw ->
149
+
150
+
(* Create shared Requests session *)
151
+
let shared_session = Requests.create ~sw env in
152
+
153
+
(* Create multiple clients sharing the same connection pools *)
154
+
let immich1 = Immiche.create ~sw ~env ~requests_session:shared_session
155
+
~base_url:"https://photos1.example.com"
156
+
~api_key:"key1" () in
157
+
158
+
let immich2 = Immiche.create ~sw ~env ~requests_session:shared_session
159
+
~base_url:"https://photos2.example.com"
160
+
~api_key:"key2" () in
161
+
162
+
(* Both clients share the same connection pools! *)
163
+
let people1 = Immiche.fetch_people immich1 in
164
+
let people2 = Immiche.fetch_people immich2 in
165
+
()
166
+
```
167
+
168
+
## Dependencies
169
+
170
+
- `eio` - Concurrent I/O library
171
+
- `requests` - HTTP client library
172
+
- `ezjsonm` - JSON parsing
173
+
- `uri` - URI encoding
174
+
- `fmt` - Formatting
175
+
- `ptime` - Time handling
176
+
177
+
## Implementation Notes
178
+
179
+
- Uses `Requests.t` for session-based HTTP requests with connection pooling
180
+
- Authentication via `x-api-key` header (set as default on session creation)
181
+
- Direct Eio style - no Lwt dependencies
182
+
- Connection pools shared across derived sessions
183
+
- Extracted and adapted from `bushel/bin/bushel_faces.ml`
184
+
185
+
## Benefits
186
+
187
+
✅ **Connection Pooling** - Automatic TCP connection reuse across requests
188
+
✅ **Clean API** - Session-level configuration passed once, not per-request
189
+
✅ **Injectable Sessions** - Can share `Requests.t` across multiple libraries
190
+
✅ **Type Safety** - Client parameterized by clock/net types
191
+
✅ **Immutable Configuration** - Derived sessions don't affect original
192
+
193
+
## License
194
+
195
+
ISC
+4
stack/immiche/dune
+4
stack/immiche/dune
+19
stack/immiche/dune-project
+19
stack/immiche/dune-project
···
1
+
(lang dune 3.0)
2
+
(name immiche)
3
+
(version 0.1.0)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(package
8
+
(name immiche)
9
+
(synopsis "Immich API client for OCaml using Eio")
10
+
(description "An Eio-based OCaml client library for Immich photo service API")
11
+
(depends
12
+
(ocaml (>= 4.14))
13
+
eio
14
+
(eio_main (>= 1.0))
15
+
requests
16
+
ezjsonm
17
+
fmt
18
+
ptime
19
+
uri))
+137
stack/immiche/immiche.ml
+137
stack/immiche/immiche.ml
···
1
+
(** Immiche - Immich API client library *)
2
+
3
+
open Printf
4
+
5
+
(** {1 Types} *)
6
+
7
+
type ('clock, 'net) t = {
8
+
base_url: string;
9
+
api_key: string;
10
+
requests_session: ('clock, 'net) Requests.t;
11
+
}
12
+
13
+
type person = {
14
+
id: string;
15
+
name: string;
16
+
birth_date: string option;
17
+
thumbnail_path: string;
18
+
is_hidden: bool;
19
+
}
20
+
21
+
type people_response = {
22
+
total: int;
23
+
visible: int;
24
+
people: person list;
25
+
}
26
+
27
+
(** {1 Client Creation} *)
28
+
29
+
let create ~sw ~env ?requests_session ~base_url ~api_key () =
30
+
let requests_session = match requests_session with
31
+
| Some session -> session
32
+
| None -> Requests.create ~sw env
33
+
in
34
+
(* Set API key header on the session *)
35
+
let requests_session = Requests.set_default_header requests_session "x-api-key" api_key in
36
+
{ base_url; api_key; requests_session }
37
+
38
+
(** {1 JSON Parsing} *)
39
+
40
+
(* Parse a single person from JSON *)
41
+
let parse_person json =
42
+
let open Ezjsonm in
43
+
let id = find json ["id"] |> get_string in
44
+
let name = find json ["name"] |> get_string in
45
+
let birth_date =
46
+
try Some (find json ["birthDate"] |> get_string)
47
+
with _ -> None
48
+
in
49
+
let thumbnail_path = find json ["thumbnailPath"] |> get_string in
50
+
let is_hidden =
51
+
try find json ["isHidden"] |> get_bool
52
+
with _ -> false
53
+
in
54
+
{ id; name; birth_date; thumbnail_path; is_hidden }
55
+
56
+
(* Parse people response from JSON *)
57
+
let parse_people_response json =
58
+
let open Ezjsonm in
59
+
let total = find json ["total"] |> get_int in
60
+
let visible = find json ["visible"] |> get_int in
61
+
let people_json = find json ["people"] in
62
+
let people = get_list parse_person people_json in
63
+
{ total; visible; people }
64
+
65
+
(* Parse a list of people from search results *)
66
+
let parse_person_list json =
67
+
let open Ezjsonm in
68
+
get_list parse_person json
69
+
70
+
(** {1 API Functions} *)
71
+
72
+
let fetch_people { base_url; requests_session; _ } =
73
+
let url = sprintf "%s/api/people" base_url in
74
+
75
+
let response = Requests.get requests_session url in
76
+
let status = Requests.Response.status_code response in
77
+
78
+
if status <> 200 then
79
+
failwith (sprintf "HTTP error: %d" status)
80
+
else
81
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
82
+
let json = Ezjsonm.from_string body_str in
83
+
parse_people_response json
84
+
85
+
let fetch_person { base_url; requests_session; _ } ~person_id =
86
+
let url = sprintf "%s/api/people/%s" base_url person_id in
87
+
88
+
let response = Requests.get requests_session url in
89
+
let status = Requests.Response.status_code response in
90
+
91
+
if status <> 200 then
92
+
failwith (sprintf "HTTP error: %d" status)
93
+
else
94
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
95
+
let json = Ezjsonm.from_string body_str in
96
+
parse_person json
97
+
98
+
let download_thumbnail { base_url; requests_session; _ } ~fs ~person_id ~output_path =
99
+
try
100
+
let url = sprintf "%s/api/people/%s/thumbnail" base_url person_id in
101
+
102
+
let response = Requests.get requests_session url in
103
+
let status = Requests.Response.status_code response in
104
+
105
+
if status <> 200 then
106
+
Error (`Msg (sprintf "HTTP error: %d" status))
107
+
else begin
108
+
let img_data = Requests.Response.body response |> Eio.Flow.read_all in
109
+
110
+
(* Ensure output directory exists *)
111
+
let dir = Filename.dirname output_path in
112
+
if not (Sys.file_exists dir) then
113
+
Unix.mkdir dir 0o755;
114
+
115
+
(* Write the image data to file *)
116
+
let path = Eio.Path.(fs / output_path) in
117
+
Eio.Path.save ~create:(`Or_truncate 0o644) path img_data;
118
+
119
+
Ok ()
120
+
end
121
+
with
122
+
| Failure msg -> Error (`Msg msg)
123
+
| exn -> Error (`Msg (Printexc.to_string exn))
124
+
125
+
let search_person { base_url; requests_session; _ } ~name =
126
+
let encoded_name = Uri.pct_encode name in
127
+
let url = sprintf "%s/api/search/person?name=%s" base_url encoded_name in
128
+
129
+
let response = Requests.get requests_session url in
130
+
let status = Requests.Response.status_code response in
131
+
132
+
if status <> 200 then
133
+
failwith (sprintf "HTTP error: %d" status)
134
+
else
135
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
136
+
let json = Ezjsonm.from_string body_str in
137
+
parse_person_list json
+100
stack/immiche/immiche.mli
+100
stack/immiche/immiche.mli
···
1
+
(** Immiche - Immich API client library
2
+
3
+
This library provides a clean Eio-based interface to interact with Immich
4
+
instances for managing people and face recognition data.
5
+
*)
6
+
7
+
(** {1 Types} *)
8
+
9
+
(** Type representing an Immich client with connection pooling *)
10
+
type ('clock, 'net) t
11
+
12
+
(** Type representing a person in Immich *)
13
+
type person = {
14
+
id: string;
15
+
name: string;
16
+
birth_date: string option;
17
+
thumbnail_path: string;
18
+
is_hidden: bool;
19
+
}
20
+
21
+
(** Type for the people API response *)
22
+
type people_response = {
23
+
total: int;
24
+
visible: int;
25
+
people: person list;
26
+
}
27
+
28
+
(** {1 Client Creation} *)
29
+
30
+
(** [create ~sw ~env ?requests_session ~base_url ~api_key ()] creates a new Immich client.
31
+
32
+
@param sw The Eio switch for resource management
33
+
@param env The Eio environment (provides clock, net, fs)
34
+
@param requests_session Optional Requests session for connection pooling.
35
+
If not provided, a new session is created.
36
+
@param base_url The base URL of the Immich instance (e.g., "https://photos.example.com")
37
+
@param api_key The API key for authentication
38
+
@return An Immich client configured for the specified instance
39
+
*)
40
+
val create :
41
+
sw:Eio.Switch.t ->
42
+
env:< clock: ([> float Eio.Time.clock_ty ] as 'clock) Eio.Resource.t;
43
+
net: ([> [> `Generic ] Eio.Net.ty ] as 'net) Eio.Resource.t;
44
+
fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->
45
+
?requests_session:('clock Eio.Resource.t, 'net Eio.Resource.t) Requests.t ->
46
+
base_url:string ->
47
+
api_key:string ->
48
+
unit -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t
49
+
50
+
(** {1 API Functions} *)
51
+
52
+
(** [fetch_people client] fetches all people from an Immich instance.
53
+
54
+
@param client The Immich client
55
+
@return A people_response containing all people and metadata
56
+
@raise Failure if the API request fails
57
+
*)
58
+
val fetch_people :
59
+
([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
60
+
people_response
61
+
62
+
(** [fetch_person client ~person_id] fetches details for a single person.
63
+
64
+
@param client The Immich client
65
+
@param person_id The ID of the person to fetch
66
+
@return The person details
67
+
@raise Failure if the API request fails or person not found
68
+
*)
69
+
val fetch_person :
70
+
([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
71
+
person_id:string ->
72
+
person
73
+
74
+
(** [download_thumbnail client ~fs ~person_id ~output_path] downloads
75
+
a person's thumbnail image to a file.
76
+
77
+
@param client The Immich client
78
+
@param fs The Eio filesystem capability
79
+
@param person_id The ID of the person whose thumbnail to download
80
+
@param output_path The file path where the thumbnail should be saved
81
+
@return Ok () on success, or Error with a message on failure
82
+
*)
83
+
val download_thumbnail :
84
+
([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
85
+
fs:_ Eio.Path.t ->
86
+
person_id:string ->
87
+
output_path:string ->
88
+
(unit, [> `Msg of string]) result
89
+
90
+
(** [search_person client ~name] searches for people by name.
91
+
92
+
@param client The Immich client
93
+
@param name The name to search for
94
+
@return A list of matching people
95
+
@raise Failure if the API request fails
96
+
*)
97
+
val search_person :
98
+
([> float Eio.Time.clock_ty ] Eio.Resource.t, [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t) t ->
99
+
name:string ->
100
+
person list
+31
stack/immiche/immiche.opam
+31
stack/immiche/immiche.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
version: "0.1.0"
4
+
synopsis: "Immich API client for OCaml using Eio"
5
+
description: "An Eio-based OCaml client library for Immich photo service API"
6
+
depends: [
7
+
"dune" {>= "3.0"}
8
+
"ocaml" {>= "4.14"}
9
+
"eio"
10
+
"eio_main" {>= "1.0"}
11
+
"requests"
12
+
"ezjsonm"
13
+
"fmt"
14
+
"ptime"
15
+
"uri"
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
+5
-4
stack/jmap/jmap-client/jmap_client.ml
+5
-4
stack/jmap/jmap-client/jmap_client.ml
···
12
12
let requests_session = Requests.create ~sw env in
13
13
14
14
(* Set authentication if configured *)
15
-
(match Jmap_connection.auth conn with
15
+
let requests_session = match Jmap_connection.auth conn with
16
16
| Some (Jmap_connection.Bearer token) ->
17
17
Requests.set_auth requests_session (Requests.Auth.bearer ~token)
18
18
| Some (Jmap_connection.Basic (user, pass)) ->
19
19
Requests.set_auth requests_session (Requests.Auth.basic ~username:user ~password:pass)
20
-
| None -> ());
20
+
| None -> requests_session
21
+
in
21
22
22
23
(* Set user agent *)
23
24
let config = Jmap_connection.config conn in
24
-
Requests.set_default_header requests_session "User-Agent"
25
-
(Jmap_connection.user_agent config);
25
+
let requests_session = Requests.set_default_header requests_session "User-Agent"
26
+
(Jmap_connection.user_agent config) in
26
27
27
28
{ session_url;
28
29
get_request = (fun ~timeout url -> Requests.get requests_session ~timeout url);
+4
stack/karakeepe/dune
+4
stack/karakeepe/dune
+19
stack/karakeepe/dune-project
+19
stack/karakeepe/dune-project
···
1
+
(lang dune 3.0)
2
+
(name karakeepe)
3
+
(version 0.1.0)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(package
8
+
(name karakeepe)
9
+
(synopsis "Karakeep API client for OCaml using Eio")
10
+
(description "An Eio-based OCaml client library for the Karakeep bookmark management service API")
11
+
(depends
12
+
(ocaml (>= 4.14))
13
+
eio
14
+
(eio_main (>= 1.0))
15
+
requests
16
+
ezjsonm
17
+
fmt
18
+
ptime
19
+
uri))
+472
stack/karakeepe/karakeepe.ml
+472
stack/karakeepe/karakeepe.ml
···
1
+
(** Karakeepe API client implementation (Eio version) *)
2
+
3
+
module J = Ezjsonm
4
+
5
+
(** Type representing a Karakeep bookmark *)
6
+
type bookmark = {
7
+
id: string;
8
+
title: string option;
9
+
url: string;
10
+
note: string option;
11
+
created_at: Ptime.t;
12
+
updated_at: Ptime.t option;
13
+
favourited: bool;
14
+
archived: bool;
15
+
tags: string list;
16
+
tagging_status: string option;
17
+
summary: string option;
18
+
content: (string * string) list;
19
+
assets: (string * string) list;
20
+
}
21
+
22
+
(** Type for Karakeep API response containing bookmarks *)
23
+
type bookmark_response = {
24
+
total: int;
25
+
data: bookmark list;
26
+
next_cursor: string option;
27
+
}
28
+
29
+
(** Parse a date string to Ptime.t, defaulting to epoch if invalid *)
30
+
let parse_date str =
31
+
match Ptime.of_rfc3339 str with
32
+
| Ok (date, _, _) -> date
33
+
| Error _ ->
34
+
Fmt.epr "Warning: could not parse date '%s'\n" str;
35
+
(* Default to epoch time *)
36
+
let span_opt = Ptime.Span.of_d_ps (0, 0L) in
37
+
match span_opt with
38
+
| None -> failwith "Internal error: couldn't create epoch time span"
39
+
| Some span ->
40
+
match Ptime.of_span span with
41
+
| Some t -> t
42
+
| None -> failwith "Internal error: couldn't create epoch time"
43
+
44
+
(** Extract a string field from JSON, returns None if not present or not a string *)
45
+
let get_string_opt json path =
46
+
try Some (J.find json path |> J.get_string)
47
+
with _ -> None
48
+
49
+
(** Extract a string list field from JSON, returns empty list if not present *)
50
+
let get_string_list json path =
51
+
try
52
+
let items_json = J.find json path in
53
+
J.get_list (fun tag -> J.find tag ["name"] |> J.get_string) items_json
54
+
with _ -> []
55
+
56
+
(** Extract a boolean field from JSON, with default value *)
57
+
let get_bool_def json path default =
58
+
try J.find json path |> J.get_bool
59
+
with _ -> default
60
+
61
+
(** Parse a single bookmark from Karakeep JSON *)
62
+
let parse_bookmark json =
63
+
let id =
64
+
try J.find json ["id"] |> J.get_string
65
+
with e ->
66
+
prerr_endline (Fmt.str "Error parsing bookmark ID: %s" (Printexc.to_string e));
67
+
prerr_endline (Fmt.str "JSON: %s" (J.value_to_string json));
68
+
failwith "Unable to parse bookmark ID"
69
+
in
70
+
71
+
let title =
72
+
try Some (J.find json ["title"] |> J.get_string)
73
+
with _ -> None
74
+
in
75
+
76
+
let url =
77
+
try J.find json ["url"] |> J.get_string
78
+
with _ -> try
79
+
J.find json ["content"; "url"] |> J.get_string
80
+
with _ -> try
81
+
J.find json ["content"; "sourceUrl"] |> J.get_string
82
+
with _ ->
83
+
match J.find_opt json ["content"; "type"] with
84
+
| Some (`String "asset") ->
85
+
(try J.find json ["content"; "sourceUrl"] |> J.get_string
86
+
with _ ->
87
+
(match J.find_opt json ["id"] with
88
+
| Some (`String id) -> "karakeep-asset://" ^ id
89
+
| _ -> failwith "No URL or asset ID found in bookmark"))
90
+
| _ ->
91
+
prerr_endline (Fmt.str "Bookmark JSON structure: %s" (J.value_to_string json));
92
+
failwith "No URL found in bookmark"
93
+
in
94
+
95
+
let note = get_string_opt json ["note"] in
96
+
97
+
let created_at =
98
+
try J.find json ["createdAt"] |> J.get_string |> parse_date
99
+
with _ ->
100
+
try J.find json ["created_at"] |> J.get_string |> parse_date
101
+
with _ -> failwith "No creation date found"
102
+
in
103
+
104
+
let updated_at =
105
+
try Some (J.find json ["updatedAt"] |> J.get_string |> parse_date)
106
+
with _ ->
107
+
try Some (J.find json ["modifiedAt"] |> J.get_string |> parse_date)
108
+
with _ -> None
109
+
in
110
+
111
+
let favourited = get_bool_def json ["favourited"] false in
112
+
let archived = get_bool_def json ["archived"] false in
113
+
let tags = get_string_list json ["tags"] in
114
+
let tagging_status = get_string_opt json ["taggingStatus"] in
115
+
let summary = get_string_opt json ["summary"] in
116
+
117
+
let content =
118
+
try
119
+
let content_json = J.find json ["content"] in
120
+
let rec extract_fields acc = function
121
+
| [] -> acc
122
+
| (k, v) :: rest ->
123
+
let value = match v with
124
+
| `String s -> s
125
+
| `Bool b -> string_of_bool b
126
+
| `Float f -> string_of_float f
127
+
| `Null -> "null"
128
+
| _ -> "complex_value"
129
+
in
130
+
extract_fields ((k, value) :: acc) rest
131
+
in
132
+
match content_json with
133
+
| `O fields -> extract_fields [] fields
134
+
| _ -> []
135
+
with _ -> []
136
+
in
137
+
138
+
let assets =
139
+
try
140
+
let assets_json = J.find json ["assets"] in
141
+
J.get_list (fun asset_json ->
142
+
let id = J.find asset_json ["id"] |> J.get_string in
143
+
let asset_type =
144
+
try J.find asset_json ["assetType"] |> J.get_string
145
+
with _ -> "unknown"
146
+
in
147
+
(id, asset_type)
148
+
) assets_json
149
+
with _ -> []
150
+
in
151
+
152
+
{ id; title; url; note; created_at; updated_at; favourited; archived; tags;
153
+
tagging_status; summary; content; assets }
154
+
155
+
(** Parse a Karakeep bookmark response *)
156
+
let parse_bookmark_response json =
157
+
prerr_endline (Fmt.str "Full response JSON: %s" (J.value_to_string json));
158
+
159
+
try
160
+
let total = J.find json ["total"] |> J.get_int in
161
+
let bookmarks_json = J.find json ["data"] in
162
+
prerr_endline "Found bookmarks in data array";
163
+
let data = J.get_list parse_bookmark bookmarks_json in
164
+
let next_cursor =
165
+
try Some (J.find json ["nextCursor"] |> J.get_string)
166
+
with _ -> None
167
+
in
168
+
{ total; data; next_cursor }
169
+
with e1 ->
170
+
prerr_endline (Fmt.str "First format parse error: %s" (Printexc.to_string e1));
171
+
try
172
+
let bookmarks_json = J.find json ["bookmarks"] in
173
+
prerr_endline "Found bookmarks in bookmarks array";
174
+
let data =
175
+
try J.get_list parse_bookmark bookmarks_json
176
+
with e ->
177
+
prerr_endline (Fmt.str "Error parsing bookmarks array: %s" (Printexc.to_string e));
178
+
[]
179
+
in
180
+
let next_cursor =
181
+
try Some (J.find json ["nextCursor"] |> J.get_string)
182
+
with _ -> None
183
+
in
184
+
{ total = List.length data; data; next_cursor }
185
+
with e2 ->
186
+
prerr_endline (Fmt.str "Second format parse error: %s" (Printexc.to_string e2));
187
+
try
188
+
let error = J.find json ["error"] |> J.get_string in
189
+
let message =
190
+
try J.find json ["message"] |> J.get_string
191
+
with _ -> "Unknown error"
192
+
in
193
+
prerr_endline (Fmt.str "API Error: %s - %s" error message);
194
+
{ total = 0; data = []; next_cursor = None }
195
+
with _ ->
196
+
try
197
+
prerr_endline "Trying alternate array format";
198
+
prerr_endline (Fmt.str "JSON structure keys: %s"
199
+
(match json with
200
+
| `O fields -> String.concat ", " (List.map (fun (k, _) -> k) fields)
201
+
| _ -> "not an object"));
202
+
203
+
if J.find_opt json ["nextCursor"] <> None then begin
204
+
prerr_endline "Found nextCursor, checking alternate structures";
205
+
let bookmarks_json =
206
+
try Some (J.find json ["data"])
207
+
with _ -> None
208
+
in
209
+
match bookmarks_json with
210
+
| Some json_array ->
211
+
prerr_endline "Found bookmarks in data field";
212
+
begin try
213
+
let data = J.get_list parse_bookmark json_array in
214
+
let next_cursor =
215
+
try Some (J.find json ["nextCursor"] |> J.get_string)
216
+
with _ -> None
217
+
in
218
+
{ total = List.length data; data; next_cursor }
219
+
with e ->
220
+
prerr_endline (Fmt.str "Error parsing bookmarks from data: %s" (Printexc.to_string e));
221
+
{ total = 0; data = []; next_cursor = None }
222
+
end
223
+
| None ->
224
+
prerr_endline "No bookmarks found in alternate structure";
225
+
{ total = 0; data = []; next_cursor = None }
226
+
end
227
+
else begin
228
+
match json with
229
+
| `A _ ->
230
+
let data =
231
+
try J.get_list parse_bookmark json
232
+
with e ->
233
+
prerr_endline (Fmt.str "Error parsing root array: %s" (Printexc.to_string e));
234
+
[]
235
+
in
236
+
{ total = List.length data; data; next_cursor = None }
237
+
| _ ->
238
+
prerr_endline "Not an array at root level";
239
+
{ total = 0; data = []; next_cursor = None }
240
+
end
241
+
with e3 ->
242
+
prerr_endline (Fmt.str "Third format parse error: %s" (Printexc.to_string e3));
243
+
{ total = 0; data = []; next_cursor = None }
244
+
245
+
(** Fetch bookmarks from a Karakeep instance with pagination support *)
246
+
let fetch_bookmarks ~sw ~env ~api_key ?(limit=50) ?(offset=0) ?cursor ?(include_content=false) ?filter_tags base_url =
247
+
let url_base = Fmt.str "%s/api/v1/bookmarks?limit=%d&includeContent=%b"
248
+
base_url limit include_content in
249
+
250
+
let url =
251
+
match cursor with
252
+
| Some cursor_value -> url_base ^ "&cursor=" ^ cursor_value
253
+
| None -> url_base ^ "&offset=" ^ string_of_int offset
254
+
in
255
+
256
+
let url = match filter_tags with
257
+
| Some tags when tags <> [] ->
258
+
let encoded_tags =
259
+
List.map (fun tag -> Uri.pct_encode ~component:`Query_key tag) tags
260
+
in
261
+
let tags_param = String.concat "," encoded_tags in
262
+
prerr_endline (Fmt.str "Adding tags filter: %s" tags_param);
263
+
url ^ "&tags=" ^ tags_param
264
+
| _ -> url
265
+
in
266
+
267
+
let headers = Requests.Headers.empty
268
+
|> Requests.Headers.set "Authorization" ("Bearer " ^ api_key) in
269
+
270
+
prerr_endline (Fmt.str "Fetching bookmarks from: %s" url);
271
+
272
+
try
273
+
let response = Requests.One.get ~sw ~clock:env#clock ~net:env#net ~headers url in
274
+
let status_code = Requests.Response.status_code response in
275
+
if status_code = 200 then begin
276
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
277
+
prerr_endline (Fmt.str "Received %d bytes of response data" (String.length body_str));
278
+
279
+
try
280
+
let json = J.from_string body_str in
281
+
parse_bookmark_response json
282
+
with e ->
283
+
prerr_endline (Fmt.str "JSON parsing error: %s" (Printexc.to_string e));
284
+
prerr_endline (Fmt.str "Response body (first 200 chars): %s"
285
+
(if String.length body_str > 200 then String.sub body_str 0 200 ^ "..." else body_str));
286
+
raise e
287
+
end else begin
288
+
prerr_endline (Fmt.str "HTTP error %d" status_code);
289
+
failwith (Fmt.str "HTTP error: %d" status_code)
290
+
end
291
+
with e ->
292
+
prerr_endline (Fmt.str "Network error: %s" (Printexc.to_string e));
293
+
raise e
294
+
295
+
(** Fetch all bookmarks from a Karakeep instance using pagination *)
296
+
let fetch_all_bookmarks ~sw ~env ~api_key ?(page_size=50) ?max_pages ?filter_tags ?(include_content=false) base_url =
297
+
let rec fetch_pages page_num cursor acc _total_count =
298
+
let response =
299
+
match cursor with
300
+
| Some cursor_str -> fetch_bookmarks ~sw ~env ~api_key ~limit:page_size ~cursor:cursor_str ~include_content ?filter_tags base_url
301
+
| None -> fetch_bookmarks ~sw ~env ~api_key ~limit:page_size ~offset:(page_num * page_size) ~include_content ?filter_tags base_url
302
+
in
303
+
304
+
let all_bookmarks = acc @ response.data in
305
+
306
+
let more_available =
307
+
match response.next_cursor with
308
+
| Some _ -> true
309
+
| None ->
310
+
let fetched_count = (page_num * page_size) + List.length response.data in
311
+
fetched_count < response.total
312
+
in
313
+
314
+
let under_max_pages = match max_pages with
315
+
| None -> true
316
+
| Some max -> page_num + 1 < max
317
+
in
318
+
319
+
if more_available && under_max_pages then
320
+
fetch_pages (page_num + 1) response.next_cursor all_bookmarks response.total
321
+
else
322
+
all_bookmarks
323
+
in
324
+
fetch_pages 0 None [] 0
325
+
326
+
(** Fetch detailed information for a single bookmark by ID *)
327
+
let fetch_bookmark_details ~sw ~env ~api_key base_url bookmark_id =
328
+
let url = Fmt.str "%s/api/v1/bookmarks/%s" base_url bookmark_id in
329
+
330
+
let headers = Requests.Headers.empty
331
+
|> Requests.Headers.set "Authorization" ("Bearer " ^ api_key) in
332
+
333
+
let response = Requests.One.get ~sw ~clock:env#clock ~net:env#net ~headers url in
334
+
let status_code = Requests.Response.status_code response in
335
+
if status_code = 200 then begin
336
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
337
+
let json = J.from_string body_str in
338
+
parse_bookmark json
339
+
end else
340
+
failwith (Fmt.str "HTTP error: %d" status_code)
341
+
342
+
(** Get the asset URL for a given asset ID *)
343
+
let get_asset_url base_url asset_id =
344
+
Fmt.str "%s/api/assets/%s" base_url asset_id
345
+
346
+
(** Fetch an asset from the Karakeep server as a binary string *)
347
+
let fetch_asset ~sw ~env ~api_key base_url asset_id =
348
+
let url = get_asset_url base_url asset_id in
349
+
350
+
let headers = Requests.Headers.empty
351
+
|> Requests.Headers.set "Authorization" ("Bearer " ^ api_key) in
352
+
353
+
let response = Requests.One.get ~sw ~clock:env#clock ~net:env#net ~headers url in
354
+
let status_code = Requests.Response.status_code response in
355
+
if status_code = 200 then
356
+
Requests.Response.body response |> Eio.Flow.read_all
357
+
else
358
+
failwith (Fmt.str "Asset fetch error: %d" status_code)
359
+
360
+
(** Create a new bookmark in Karakeep with optional tags *)
361
+
let create_bookmark ~sw ~env ~api_key ~url ?title ?note ?tags ?(favourited=false) ?(archived=false) base_url =
362
+
let body_obj = [
363
+
("type", `String "link");
364
+
("url", `String url);
365
+
("favourited", `Bool favourited);
366
+
("archived", `Bool archived);
367
+
] in
368
+
369
+
let body_obj = match title with
370
+
| Some title_str -> ("title", `String title_str) :: body_obj
371
+
| None -> body_obj
372
+
in
373
+
374
+
let body_obj = match note with
375
+
| Some note_str -> ("note", `String note_str) :: body_obj
376
+
| None -> body_obj
377
+
in
378
+
379
+
let body_json = `O body_obj in
380
+
let body_str = J.to_string body_json in
381
+
382
+
let headers = Requests.Headers.empty
383
+
|> Requests.Headers.set "Authorization" ("Bearer " ^ api_key)
384
+
|> Requests.Headers.set "Content-Type" "application/json"
385
+
in
386
+
387
+
let url_endpoint = Fmt.str "%s/api/v1/bookmarks" base_url in
388
+
let body = Requests.Body.of_string Requests.Mime.json body_str in
389
+
let response = Requests.One.post ~sw ~clock:env#clock ~net:env#net ~headers ~body url_endpoint in
390
+
391
+
let status_code = Requests.Response.status_code response in
392
+
if status_code = 201 || status_code = 200 then begin
393
+
let body_str = Requests.Response.body response |> Eio.Flow.read_all in
394
+
let json = J.from_string body_str in
395
+
let bookmark = parse_bookmark json in
396
+
397
+
match tags with
398
+
| Some tag_list when tag_list <> [] ->
399
+
let tag_objects = List.map (fun tag_name ->
400
+
`O [("tagName", `String tag_name)]
401
+
) tag_list in
402
+
403
+
let tags_body = `O [("tags", `A tag_objects)] in
404
+
let tags_body_str = J.to_string tags_body in
405
+
406
+
let tags_url = Fmt.str "%s/api/v1/bookmarks/%s/tags" base_url bookmark.id in
407
+
let tags_body = Requests.Body.of_string Requests.Mime.json tags_body_str in
408
+
let tags_response = Requests.One.post ~sw ~clock:env#clock ~net:env#net ~headers ~body:tags_body tags_url in
409
+
410
+
let tags_status = Requests.Response.status_code tags_response in
411
+
if tags_status = 200 then
412
+
fetch_bookmark_details ~sw ~env ~api_key base_url bookmark.id
413
+
else
414
+
bookmark
415
+
| _ -> bookmark
416
+
end else begin
417
+
let error_body = Requests.Response.body response |> Eio.Flow.read_all in
418
+
failwith (Fmt.str "Failed to create bookmark. HTTP error: %d. Details: %s" status_code error_body)
419
+
end
420
+
421
+
(** Convert a Karakeep bookmark to Bushel.Link.t compatible structure *)
422
+
let to_bushel_link ?base_url bookmark =
423
+
let description =
424
+
match bookmark.title with
425
+
| Some title when title <> "" -> title
426
+
| _ ->
427
+
let content_title = List.assoc_opt "title" bookmark.content in
428
+
match content_title with
429
+
| Some title when title <> "" && title <> "null" -> title
430
+
| _ -> bookmark.url
431
+
in
432
+
let date = Ptime.to_date bookmark.created_at in
433
+
434
+
let metadata =
435
+
(match bookmark.summary with Some s -> [("summary", s)] | None -> []) @
436
+
(List.filter_map (fun (id, asset_type) ->
437
+
match asset_type with
438
+
| "screenshot" | "bannerImage" -> Some (asset_type, id)
439
+
| _ -> None
440
+
) bookmark.assets) @
441
+
(List.filter_map (fun (k, v) ->
442
+
if k = "favicon" && v <> "" && v <> "null" then Some ("favicon", v) else None
443
+
) bookmark.content)
444
+
in
445
+
446
+
let karakeep =
447
+
match base_url with
448
+
| Some url ->
449
+
Some {
450
+
Bushel.Link.remote_url = url;
451
+
id = bookmark.id;
452
+
tags = bookmark.tags;
453
+
metadata = metadata;
454
+
}
455
+
| None -> None
456
+
in
457
+
458
+
let bushel_slugs =
459
+
List.filter_map (fun tag ->
460
+
if String.starts_with ~prefix:"bushel:" tag then
461
+
Some (String.sub tag 7 (String.length tag - 7))
462
+
else
463
+
None
464
+
) bookmark.tags
465
+
in
466
+
467
+
let bushel =
468
+
if bushel_slugs = [] then None
469
+
else Some { Bushel.Link.slugs = bushel_slugs; tags = [] }
470
+
in
471
+
472
+
{ Bushel.Link.url = bookmark.url; date; description; karakeep; bushel }
+32
stack/karakeepe/karakeepe.opam
+32
stack/karakeepe/karakeepe.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
version: "0.1.0"
4
+
synopsis: "Karakeep API client for OCaml using Eio"
5
+
description:
6
+
"An Eio-based OCaml client library for the Karakeep bookmark management service API"
7
+
depends: [
8
+
"dune" {>= "3.0"}
9
+
"ocaml" {>= "4.14"}
10
+
"eio"
11
+
"eio_main" {>= "1.0"}
12
+
"requests"
13
+
"ezjsonm"
14
+
"fmt"
15
+
"ptime"
16
+
"uri"
17
+
"odoc" {with-doc}
18
+
]
19
+
build: [
20
+
["dune" "subst"] {dev}
21
+
[
22
+
"dune"
23
+
"build"
24
+
"-p"
25
+
name
26
+
"-j"
27
+
jobs
28
+
"@install"
29
+
"@runtest" {with-test}
30
+
"@doc" {with-doc}
31
+
]
32
+
]
+39
stack/peertubee/README.md
+39
stack/peertubee/README.md
···
1
+
# PeerTubee - Eio-based PeerTube API Client
2
+
3
+
This is a port of the PeerTube library from Lwt/Cohttp to Eio/Requests.
4
+
5
+
## Changes from Original
6
+
7
+
- **Removed** `open Lwt.Infix`
8
+
- **Replaced** all `Lwt.t` return types with direct return types (direct-style)
9
+
- **Added** `~sw:Eio.Switch.t` and `~env:<...>` parameters to all public functions
10
+
- **Replaced** `Cohttp_lwt_unix.Client.get` with `Requests.One.get`
11
+
- **Replaced** `Cohttp_lwt.Body.to_string body >>= fun s ->` with `let s = Requests.Response.body response |> Eio.Flow.read_all in`
12
+
- **Replaced** `>>=` (Lwt.bind) with direct let bindings
13
+
- **Replaced** `Lwt.return` with direct values
14
+
- **Replaced** `Lwt.return_ok`/`Lwt.return_error` with `Ok`/`Error`
15
+
- **Replaced** `open_out_bin` with `Eio.Path.save` for file writing
16
+
- **Used** `Requests.One.create` with `Eio.Stdenv.clock` and `Eio.Stdenv.net`
17
+
18
+
## Statistics
19
+
20
+
- Original: 191 lines
21
+
- Ported: 188 lines
22
+
- Functions: 8 public functions
23
+
- All JSON parsing logic preserved
24
+
- All type definitions preserved
25
+
26
+
## Files Created
27
+
28
+
- `/workspace/stack/bushel/peertubee/peertubee.ml` - Implementation (188 lines)
29
+
- `/workspace/stack/bushel/peertubee/peertubee.mli` - Interface (69 lines)
30
+
- `/workspace/stack/bushel/peertubee/dune` - Build configuration
31
+
- `/workspace/stack/bushel/peertubee.opam` - Package metadata
32
+
33
+
## Dependencies
34
+
35
+
- ezjsonm - JSON parsing
36
+
- eio + eio.core - Effects-based concurrency
37
+
- requests - HTTP client
38
+
- ptime - Time handling
39
+
- fmt - Formatted output
+4
stack/peertubee/dune
+4
stack/peertubee/dune
+18
stack/peertubee/dune-project
+18
stack/peertubee/dune-project
···
1
+
(lang dune 3.0)
2
+
(name peertubee)
3
+
(version 0.1.0)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(package
8
+
(name peertubee)
9
+
(synopsis "PeerTube API client for OCaml using Eio")
10
+
(description "An Eio-based OCaml client library for PeerTube video platform instances")
11
+
(depends
12
+
(ocaml (>= 4.14))
13
+
eio
14
+
(eio_main (>= 1.0))
15
+
requests
16
+
ezjsonm
17
+
fmt
18
+
ptime))
+31
stack/peertubee/peertubee.opam
+31
stack/peertubee/peertubee.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
version: "0.1.0"
4
+
synopsis: "PeerTube API client for OCaml using Eio"
5
+
description:
6
+
"An Eio-based OCaml client library for PeerTube video platform instances"
7
+
depends: [
8
+
"dune" {>= "3.0"}
9
+
"ocaml" {>= "4.14"}
10
+
"eio"
11
+
"eio_main" {>= "1.0"}
12
+
"requests"
13
+
"ezjsonm"
14
+
"fmt"
15
+
"ptime"
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
+5
-3
stack/requests/bin/ocurl.ml
+5
-3
stack/requests/bin/ocurl.ml
···
229
229
~follow_redirects ~max_redirects ?timeout:timeout_obj env in
230
230
231
231
(* Set authentication if provided *)
232
-
(match auth with
232
+
let req = match auth with
233
233
| Some auth_str ->
234
234
(match parse_auth auth_str with
235
235
| Some (user, pass) ->
236
236
Requests.set_auth req
237
237
(Requests.Auth.basic ~username:user ~password:pass)
238
238
| None ->
239
-
Logs.warn (fun m -> m "Invalid auth format, ignoring"))
240
-
| None -> ());
239
+
Logs.warn (fun m -> m "Invalid auth format, ignoring");
240
+
req)
241
+
| None -> req
242
+
in
241
243
242
244
(* Build headers from command line *)
243
245
let cmd_headers = List.fold_left (fun hdrs header_str ->
+112
-167
stack/requests/lib/one.ml
+112
-167
stack/requests/lib/one.ml
···
1
1
let src = Logs.Src.create "requests.one" ~doc:"One-shot HTTP Requests"
2
2
module Log = (val Logs.src_log src : Logs.LOG)
3
3
4
-
type ('clock,'net) t = {
5
-
clock : 'clock;
6
-
net : 'net;
7
-
default_headers : Headers.t;
8
-
timeout : Timeout.t;
9
-
max_retries : int;
10
-
retry_backoff : float;
11
-
verify_tls : bool;
12
-
tls_config : Tls.Config.client option;
13
-
http_pool : ('clock, 'net) Conpool.t; (* For HTTP connections *)
14
-
https_pool : ('clock, 'net) Conpool.t; (* For HTTPS connections *)
15
-
}
4
+
(* Helper to create TCP connection to host:port *)
5
+
let connect_tcp ~sw ~net ~host ~port =
6
+
Log.debug (fun m -> m "Connecting to %s:%d" host port);
7
+
(* Resolve hostname to IP address *)
8
+
let addrs = Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) in
9
+
match addrs with
10
+
| addr :: _ ->
11
+
Log.debug (fun m -> m "Resolved %s, connecting..." host);
12
+
Eio.Net.connect ~sw net addr
13
+
| [] ->
14
+
let msg = Printf.sprintf "Failed to resolve hostname: %s" host in
15
+
Log.err (fun m -> m "%s" msg);
16
+
failwith msg
16
17
17
-
let create
18
-
~sw
19
-
?(default_headers = Headers.empty)
20
-
?(timeout = Timeout.default)
21
-
?(max_retries = 3)
22
-
?(retry_backoff = 2.0)
23
-
?(verify_tls = true)
24
-
?tls_config
25
-
?(max_connections_per_host = 10)
26
-
?(connection_idle_timeout = 60.0)
27
-
?(connection_lifetime = 300.0)
28
-
~clock
29
-
~net
30
-
() =
31
-
(* Create default TLS config if verify_tls is true and no custom config provided *)
32
-
let tls_config =
33
-
match tls_config, verify_tls with
34
-
| Some config, _ -> Some config
18
+
(* Helper to wrap connection with TLS if needed *)
19
+
let wrap_tls flow ~host ~verify_tls ~tls_config =
20
+
Log.debug (fun m -> m "Wrapping connection with TLS for %s (verify=%b)" host verify_tls);
21
+
22
+
(* Get or create TLS config *)
23
+
let tls_cfg = match tls_config, verify_tls with
24
+
| Some cfg, _ -> cfg
35
25
| None, true ->
36
26
(* Use CA certificates for verification *)
37
27
(match Ca_certs.authenticator () with
38
28
| Ok authenticator ->
39
29
(match Tls.Config.client ~authenticator () with
40
-
| Ok cfg -> Some cfg
30
+
| Ok cfg -> cfg
41
31
| Error (`Msg msg) ->
42
-
Log.warn (fun m -> m "Failed to create TLS config: %s" msg);
43
-
None)
32
+
Log.err (fun m -> m "Failed to create TLS config: %s" msg);
33
+
failwith ("TLS config error: " ^ msg))
44
34
| Error (`Msg msg) ->
45
-
Log.warn (fun m -> m "Failed to load CA certificates: %s" msg);
46
-
None)
47
-
| None, false -> None
35
+
Log.err (fun m -> m "Failed to load CA certificates: %s" msg);
36
+
failwith ("CA certificates error: " ^ msg))
37
+
| None, false ->
38
+
(* No verification *)
39
+
match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
40
+
| Ok cfg -> cfg
41
+
| Error (`Msg msg) -> failwith ("TLS config error: " ^ msg)
48
42
in
49
43
50
-
(* Create connection pools - one for HTTP, one for HTTPS *)
51
-
let pool_config = Conpool.Config.make
52
-
~max_connections_per_endpoint:max_connections_per_host
53
-
~max_idle_time:connection_idle_timeout
54
-
~max_connection_lifetime:connection_lifetime
55
-
()
44
+
(* Get domain name for SNI *)
45
+
let domain = match Domain_name.of_string host with
46
+
| Ok dn -> (match Domain_name.host dn with
47
+
| Ok d -> d
48
+
| Error (`Msg msg) ->
49
+
Log.err (fun m -> m "Invalid hostname for TLS: %s (%s)" host msg);
50
+
failwith ("Invalid hostname: " ^ msg))
51
+
| Error (`Msg msg) ->
52
+
Log.err (fun m -> m "Invalid hostname for TLS: %s (%s)" host msg);
53
+
failwith ("Invalid hostname: " ^ msg)
56
54
in
57
55
58
-
(* HTTP pool - plain TCP connections *)
59
-
let http_pool = Conpool.create
60
-
~sw
61
-
~net
62
-
~clock
63
-
~config:pool_config
64
-
()
65
-
in
56
+
(Tls_eio.client_of_flow ~host:domain tls_cfg flow :> [`Close | `Flow | `R | `Shutdown | `W] Eio.Resource.t)
66
57
67
-
(* HTTPS pool - TLS-wrapped connections *)
68
-
let https_tls_config = Option.map (fun cfg ->
69
-
Conpool.Tls_config.make ~config:cfg ()
70
-
) tls_config in
58
+
(* Parse URL and connect directly (no pooling) *)
59
+
let connect_to_url ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config =
60
+
let uri = Uri.of_string url in
71
61
72
-
let https_pool = Conpool.create
73
-
~sw
74
-
~net
75
-
~clock
76
-
?tls:https_tls_config
77
-
~config:pool_config
78
-
()
62
+
(* Extract host and port *)
63
+
let host = match Uri.host uri with
64
+
| Some h -> h
65
+
| None -> failwith ("URL must contain a host: " ^ url)
79
66
in
80
67
81
-
Log.info (fun m -> m "Created HTTP client with connection pools (max_per_host=%d, TLS=%b)"
82
-
max_connections_per_host (Option.is_some https_tls_config));
68
+
let is_https = Uri.scheme uri = Some "https" in
69
+
let default_port = if is_https then 443 else 80 in
70
+
let port = Option.value (Uri.port uri) ~default:default_port in
83
71
84
-
{
85
-
clock;
86
-
net;
87
-
default_headers;
88
-
timeout;
89
-
max_retries;
90
-
retry_backoff;
91
-
verify_tls;
92
-
tls_config;
93
-
http_pool;
94
-
https_pool;
95
-
}
72
+
(* Apply connection timeout if specified *)
73
+
let connect_fn () =
74
+
let tcp_flow = connect_tcp ~sw ~net ~host ~port in
75
+
if is_https then
76
+
wrap_tls tcp_flow ~host ~verify_tls ~tls_config
77
+
else
78
+
(tcp_flow :> [`Close | `Flow | `R | `Shutdown | `W] Eio.Resource.t)
79
+
in
96
80
97
-
let default ~sw ~clock ~net =
98
-
create ~sw ~clock ~net ()
81
+
match timeout with
82
+
| Some t ->
83
+
let timeout_seconds = Timeout.total t in
84
+
(match timeout_seconds with
85
+
| Some seconds ->
86
+
Log.debug (fun m -> m "Setting connection timeout: %.2f seconds" seconds);
87
+
Eio.Time.with_timeout_exn clock seconds connect_fn
88
+
| None -> connect_fn ())
89
+
| None -> connect_fn ()
99
90
100
-
(* Accessors *)
101
-
let clock t = t.clock
102
-
let net t = t.net
103
-
let default_headers t = t.default_headers
104
-
let timeout t = t.timeout
105
-
let max_retries t = t.max_retries
106
-
let retry_backoff t = t.retry_backoff
107
-
let verify_tls t = t.verify_tls
108
-
let tls_config t = t.tls_config
91
+
(* Main request implementation - completely stateless *)
92
+
let request ~sw ~clock ~net ?headers ?body ?auth ?timeout
93
+
?(follow_redirects = true) ?(max_redirects = 10)
94
+
?(verify_tls = true) ?tls_config ~method_ url =
109
95
110
-
(* HTTP Request Methods *)
111
-
112
-
(* Helper to get client or use default *)
113
-
let get_client client =
114
-
match client with
115
-
| Some c -> c
116
-
| None -> failwith "No client provided"
117
-
118
-
(* Main request implementation with connection pooling *)
119
-
let request ~sw ?client ?headers ?body ?auth ?timeout ?follow_redirects
120
-
?max_redirects ~method_ url =
121
-
let client = get_client client in
122
96
let start_time = Unix.gettimeofday () in
123
-
124
97
let method_str = Method.to_string method_ in
125
98
Log.debug (fun m -> m "[One] Executing %s request to %s" method_str url);
126
99
127
100
(* Prepare headers *)
128
-
let headers = match headers with
129
-
| Some h -> h
130
-
| None -> default_headers client
131
-
in
101
+
let headers = Option.value headers ~default:Headers.empty in
132
102
133
103
(* Apply auth *)
134
104
let headers = match auth with
···
152
122
| Some b -> Body.Private.to_string b
153
123
in
154
124
155
-
(* Execute request with pooled connection *)
125
+
(* Execute request with redirects *)
156
126
let rec make_with_redirects url_to_fetch redirects_left =
157
127
let uri_to_fetch = Uri.of_string url_to_fetch in
158
128
159
-
(* Parse the redirect URL to get correct host and port *)
160
-
let redirect_host = match Uri.host uri_to_fetch with
161
-
| Some h -> h
162
-
| None -> failwith "Redirect URL must contain a host"
163
-
in
164
-
let redirect_port = match Uri.scheme uri_to_fetch, Uri.port uri_to_fetch with
165
-
| Some "https", None -> 443
166
-
| Some "https", Some p -> p
167
-
| Some "http", None -> 80
168
-
| Some "http", Some p -> p
169
-
| _, Some p -> p
170
-
| _ -> 80
171
-
in
129
+
(* Connect to URL (opens new TCP connection) *)
130
+
let flow = connect_to_url ~sw ~clock ~net ~url:url_to_fetch
131
+
~timeout ~verify_tls ~tls_config in
172
132
173
-
(* Create endpoint for this specific URL *)
174
-
let endpoint = Conpool.Endpoint.make ~host:redirect_host ~port:redirect_port in
175
-
176
-
(* Determine if we need TLS based on this URL's scheme *)
177
-
let is_https = match Uri.scheme uri_to_fetch with
178
-
| Some "https" -> true
179
-
| _ -> false
180
-
in
181
-
182
-
(* Choose the appropriate connection pool for this URL *)
183
-
let pool = if is_https then client.https_pool else client.http_pool in
184
-
185
-
let make_request_fn () =
186
-
Conpool.with_connection pool endpoint (fun flow ->
187
-
(* Flow is already TLS-wrapped if from https_pool, plain TCP if from http_pool *)
188
-
(* Use our low-level HTTP client *)
189
-
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch ~headers ~body_str:request_body_str flow
190
-
)
191
-
in
192
-
193
-
(* Apply timeout if specified *)
133
+
(* Make HTTP request using low-level client *)
194
134
let status, resp_headers, response_body_str =
195
-
match timeout with
196
-
| Some t ->
197
-
let timeout_seconds = Timeout.total t in
198
-
(match timeout_seconds with
199
-
| Some seconds ->
200
-
Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds);
201
-
Eio.Time.with_timeout_exn (clock client) seconds make_request_fn
202
-
| None -> make_request_fn ())
203
-
| None -> make_request_fn ()
135
+
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
136
+
~headers ~body_str:request_body_str flow
204
137
in
205
138
206
139
Log.info (fun m -> m "Received response: status=%d" status);
207
140
208
141
(* Handle redirects if enabled *)
209
-
let follow_redirects = Option.value follow_redirects ~default:true in
210
142
if follow_redirects && (status >= 300 && status < 400) then begin
211
143
if redirects_left <= 0 then begin
212
-
let max_redirects = Option.value max_redirects ~default:10 in
213
144
Log.err (fun m -> m "Too many redirects (%d) for %s" max_redirects url);
214
145
raise (Error.TooManyRedirects { url; count = max_redirects; max = max_redirects })
215
146
end;
···
225
156
(status, resp_headers, response_body_str, url_to_fetch)
226
157
in
227
158
228
-
let max_redirects = Option.value max_redirects ~default:10 in
229
159
let final_status, final_headers, final_body_str, final_url =
230
160
make_with_redirects url max_redirects
231
161
in
···
245
175
~elapsed
246
176
247
177
(* Convenience methods *)
248
-
let get ~sw ?client ?headers ?auth ?timeout ?follow_redirects ?max_redirects url =
249
-
request ~sw ?client ?headers ?auth ?timeout ?follow_redirects ?max_redirects
178
+
let get ~sw ~clock ~net ?headers ?auth ?timeout
179
+
?follow_redirects ?max_redirects ?verify_tls ?tls_config url =
180
+
request ~sw ~clock ~net ?headers ?auth ?timeout
181
+
?follow_redirects ?max_redirects ?verify_tls ?tls_config
250
182
~method_:`GET url
251
183
252
-
let post ~sw ?client ?headers ?body ?auth ?timeout url =
253
-
request ~sw ?client ?headers ?body ?auth ?timeout ~method_:`POST url
184
+
let post ~sw ~clock ~net ?headers ?body ?auth ?timeout
185
+
?verify_tls ?tls_config url =
186
+
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
187
+
?verify_tls ?tls_config ~method_:`POST url
254
188
255
-
let put ~sw ?client ?headers ?body ?auth ?timeout url =
256
-
request ~sw ?client ?headers ?body ?auth ?timeout ~method_:`PUT url
189
+
let put ~sw ~clock ~net ?headers ?body ?auth ?timeout
190
+
?verify_tls ?tls_config url =
191
+
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
192
+
?verify_tls ?tls_config ~method_:`PUT url
257
193
258
-
let delete ~sw ?client ?headers ?auth ?timeout url =
259
-
request ~sw ?client ?headers ?auth ?timeout ~method_:`DELETE url
194
+
let delete ~sw ~clock ~net ?headers ?auth ?timeout
195
+
?verify_tls ?tls_config url =
196
+
request ~sw ~clock ~net ?headers ?auth ?timeout
197
+
?verify_tls ?tls_config ~method_:`DELETE url
260
198
261
-
let head ~sw ?client ?headers ?auth ?timeout url =
262
-
request ~sw ?client ?headers ?auth ?timeout ~method_:`HEAD url
199
+
let head ~sw ~clock ~net ?headers ?auth ?timeout
200
+
?verify_tls ?tls_config url =
201
+
request ~sw ~clock ~net ?headers ?auth ?timeout
202
+
?verify_tls ?tls_config ~method_:`HEAD url
263
203
264
-
let patch ~sw ?client ?headers ?body ?auth ?timeout url =
265
-
request ~sw ?client ?headers ?body ?auth ?timeout ~method_:`PATCH url
204
+
let patch ~sw ~clock ~net ?headers ?body ?auth ?timeout
205
+
?verify_tls ?tls_config url =
206
+
request ~sw ~clock ~net ?headers ?body ?auth ?timeout
207
+
?verify_tls ?tls_config ~method_:`PATCH url
266
208
267
-
let upload ~sw ?client ?headers ?auth ?timeout ?method_ ?mime ?length
268
-
?on_progress ~source url =
209
+
let upload ~sw ~clock ~net ?headers ?auth ?timeout ?method_ ?mime ?length
210
+
?on_progress ?verify_tls ?tls_config ~source url =
269
211
let method_ = Option.value method_ ~default:`POST in
270
212
let mime = Option.value mime ~default:Mime.octet_stream in
271
213
···
281
223
in
282
224
283
225
let body = Body.of_stream ?length mime tracked_source in
284
-
request ~sw ?client ?headers ~body ?auth ?timeout ~method_ url
226
+
request ~sw ~clock ~net ?headers ~body ?auth ?timeout
227
+
?verify_tls ?tls_config ~method_ url
285
228
286
-
let download ~sw ?client ?headers ?auth ?timeout ?on_progress url ~sink =
287
-
let response = get ~sw ?client ?headers ?auth ?timeout url in
229
+
let download ~sw ~clock ~net ?headers ?auth ?timeout ?on_progress
230
+
?verify_tls ?tls_config url ~sink =
231
+
let response = get ~sw ~clock ~net ?headers ?auth ?timeout
232
+
?verify_tls ?tls_config url in
288
233
289
234
try
290
235
(* Get content length for progress tracking *)
+80
-94
stack/requests/lib/one.mli
+80
-94
stack/requests/lib/one.mli
···
1
1
(** One-shot HTTP client for stateless requests
2
2
3
3
The One module provides a stateless HTTP client for single requests without
4
-
session state like cookies or persistent configuration. For stateful requests
5
-
with automatic cookie handling and persistent configuration, use the main
6
-
{!Requests} module instead.
4
+
session state like cookies, connection pooling, or persistent configuration.
5
+
Each request opens a new connection that is closed after use.
6
+
7
+
For stateful requests with automatic cookie handling, connection pooling,
8
+
and persistent configuration, use the main {!Requests} module instead.
7
9
8
10
{2 Examples}
9
11
···
12
14
13
15
let () = run @@ fun env ->
14
16
Switch.run @@ fun sw ->
15
-
16
-
(* Create a one-shot client *)
17
-
let client = One.create ~clock:env#clock ~net:env#net () in
18
17
19
18
(* Simple GET request *)
20
-
let response = One.get ~sw ~client "https://example.com" in
19
+
let response = One.get ~sw
20
+
~clock:env#clock ~net:env#net
21
+
"https://example.com" in
21
22
Printf.printf "Status: %d\n" (Response.status_code response);
22
23
Response.close response;
23
24
24
25
(* POST with JSON body *)
25
-
let response = One.post ~sw ~client
26
+
let response = One.post ~sw
27
+
~clock:env#clock ~net:env#net
26
28
~body:(Body.json {|{"key": "value"}|})
27
29
~headers:(Headers.empty |> Headers.content_type Mime.json)
28
30
"https://api.example.com/data" in
29
31
Response.close response;
30
32
31
33
(* Download file with streaming *)
32
-
One.download ~sw ~client
34
+
One.download ~sw
35
+
~clock:env#clock ~net:env#net
33
36
"https://example.com/large-file.zip"
34
37
~sink:(Eio.Path.(fs / "download.zip" |> sink))
35
38
]}
···
38
41
(** Log source for one-shot request operations *)
39
42
val src : Logs.Src.t
40
43
41
-
type ('a,'b) t
42
-
(** One-shot client configuration with clock and network types.
43
-
The type parameters track the Eio environment capabilities. *)
44
-
45
-
(** {1 Creation} *)
46
-
47
-
val create :
48
-
sw:Eio.Switch.t ->
49
-
?default_headers:Headers.t ->
50
-
?timeout:Timeout.t ->
51
-
?max_retries:int ->
52
-
?retry_backoff:float ->
53
-
?verify_tls:bool ->
54
-
?tls_config:Tls.Config.client ->
55
-
?max_connections_per_host:int ->
56
-
?connection_idle_timeout:float ->
57
-
?connection_lifetime:float ->
58
-
clock:'a Eio.Time.clock ->
59
-
net:'b Eio.Net.t ->
60
-
unit -> ('a Eio.Time.clock, 'b Eio.Net.t) t
61
-
(** [create ~sw ?default_headers ?timeout ?max_retries ?retry_backoff ?verify_tls ?tls_config ~clock ~net ()]
62
-
creates a new HTTP client with connection pooling.
63
-
64
-
@param sw Switch for resource management (client bound to this switch)
65
-
@param default_headers Headers to include in every request (default: empty)
66
-
@param timeout Default timeout configuration (default: 30s connect, 60s read)
67
-
@param max_retries Maximum number of retries for failed requests (default: 3)
68
-
@param retry_backoff Exponential backoff factor for retries (default: 2.0)
69
-
@param verify_tls Whether to verify TLS certificates (default: true)
70
-
@param tls_config Custom TLS configuration (default: uses system CA certificates)
71
-
@param max_connections_per_host Maximum pooled connections per host:port (default: 10)
72
-
@param connection_idle_timeout Max idle time before closing pooled connection (default: 60s)
73
-
@param connection_lifetime Max lifetime of any pooled connection (default: 300s)
74
-
@param clock Eio clock for timeouts and scheduling
75
-
@param net Eio network capability for making connections
76
-
*)
77
-
78
-
val default : sw:Eio.Switch.t -> clock:'a Eio.Time.clock -> net:'b Eio.Net.t -> ('a Eio.Time.clock, 'b Eio.Net.t) t
79
-
(** [default ~sw ~clock ~net] creates a client with default configuration.
80
-
Equivalent to [create ~sw ~clock ~net ()]. *)
81
-
82
-
(** {1 Configuration Access} *)
83
-
84
-
val clock : ('a,'b) t -> 'a
85
-
(** [clock client] returns the clock capability. *)
86
-
87
-
val net : ('a,'b) t -> 'b
88
-
(** [net client] returns the network capability. *)
89
-
90
-
val default_headers : ('a,'b) t -> Headers.t
91
-
(** [default_headers client] returns the default headers. *)
92
-
93
-
val timeout : ('a,'b) t -> Timeout.t
94
-
(** [timeout client] returns the timeout configuration. *)
95
-
96
-
val max_retries : ('a,'b) t -> int
97
-
(** [max_retries client] returns the maximum retry count. *)
98
-
99
-
val retry_backoff : ('a,'b) t -> float
100
-
(** [retry_backoff client] returns the retry backoff factor. *)
101
-
102
-
val verify_tls : ('a,'b) t -> bool
103
-
(** [verify_tls client] returns whether TLS verification is enabled. *)
104
-
105
-
val tls_config : ('a,'b) t -> Tls.Config.client option
106
-
(** [tls_config client] returns the TLS configuration if set. *)
44
+
(** {1 HTTP Request Methods}
107
45
108
-
(** {1 HTTP Request Methods} *)
46
+
All functions are stateless - they open a new TCP connection for each request
47
+
and close it when the switch closes. No connection pooling or reuse. *)
109
48
110
49
val request :
111
50
sw:Eio.Switch.t ->
112
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
51
+
clock:_ Eio.Time.clock ->
52
+
net:_ Eio.Net.t ->
113
53
?headers:Headers.t ->
114
54
?body:Body.t ->
115
55
?auth:Auth.t ->
116
56
?timeout:Timeout.t ->
117
57
?follow_redirects:bool ->
118
58
?max_redirects:int ->
59
+
?verify_tls:bool ->
60
+
?tls_config:Tls.Config.client ->
119
61
method_:Method.t ->
120
62
string ->
121
63
Response.t
122
-
(** Make a streaming request *)
64
+
(** [request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?follow_redirects
65
+
?max_redirects ?verify_tls ?tls_config ~method_ url] makes a single HTTP
66
+
request without connection pooling.
67
+
68
+
Each call opens a new TCP connection (with TLS if https://), makes the
69
+
request, and closes the connection when the switch closes.
70
+
71
+
@param sw Switch for resource management (response/connection bound to this)
72
+
@param clock Clock for timeouts
73
+
@param net Network interface for TCP connections
74
+
@param headers Request headers (default: empty)
75
+
@param body Request body (default: none)
76
+
@param auth Authentication to apply (default: none)
77
+
@param timeout Request timeout (default: 30s connect, 60s read)
78
+
@param follow_redirects Whether to follow HTTP redirects (default: true)
79
+
@param max_redirects Maximum redirects to follow (default: 10)
80
+
@param verify_tls Whether to verify TLS certificates (default: true)
81
+
@param tls_config Custom TLS configuration (default: system CA certs)
82
+
@param method_ HTTP method (GET, POST, etc.)
83
+
@param url URL to request
84
+
*)
123
85
124
86
val get :
125
87
sw:Eio.Switch.t ->
126
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
88
+
clock:_ Eio.Time.clock ->
89
+
net:_ Eio.Net.t ->
127
90
?headers:Headers.t ->
128
91
?auth:Auth.t ->
129
92
?timeout:Timeout.t ->
130
93
?follow_redirects:bool ->
131
94
?max_redirects:int ->
95
+
?verify_tls:bool ->
96
+
?tls_config:Tls.Config.client ->
132
97
string ->
133
98
Response.t
134
-
(** GET request *)
99
+
(** GET request. See {!request} for parameter details. *)
135
100
136
101
val post :
137
102
sw:Eio.Switch.t ->
138
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
103
+
clock:_ Eio.Time.clock ->
104
+
net:_ Eio.Net.t ->
139
105
?headers:Headers.t ->
140
106
?body:Body.t ->
141
107
?auth:Auth.t ->
142
108
?timeout:Timeout.t ->
109
+
?verify_tls:bool ->
110
+
?tls_config:Tls.Config.client ->
143
111
string ->
144
112
Response.t
145
-
(** POST request *)
113
+
(** POST request. See {!request} for parameter details. *)
146
114
147
115
val put :
148
116
sw:Eio.Switch.t ->
149
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
117
+
clock:_ Eio.Time.clock ->
118
+
net:_ Eio.Net.t ->
150
119
?headers:Headers.t ->
151
120
?body:Body.t ->
152
121
?auth:Auth.t ->
153
122
?timeout:Timeout.t ->
123
+
?verify_tls:bool ->
124
+
?tls_config:Tls.Config.client ->
154
125
string ->
155
126
Response.t
156
-
(** PUT request *)
127
+
(** PUT request. See {!request} for parameter details. *)
157
128
158
129
val delete :
159
130
sw:Eio.Switch.t ->
160
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
131
+
clock:_ Eio.Time.clock ->
132
+
net:_ Eio.Net.t ->
161
133
?headers:Headers.t ->
162
134
?auth:Auth.t ->
163
135
?timeout:Timeout.t ->
136
+
?verify_tls:bool ->
137
+
?tls_config:Tls.Config.client ->
164
138
string ->
165
139
Response.t
166
-
(** DELETE request *)
140
+
(** DELETE request. See {!request} for parameter details. *)
167
141
168
142
val head :
169
143
sw:Eio.Switch.t ->
170
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
144
+
clock:_ Eio.Time.clock ->
145
+
net:_ Eio.Net.t ->
171
146
?headers:Headers.t ->
172
147
?auth:Auth.t ->
173
148
?timeout:Timeout.t ->
149
+
?verify_tls:bool ->
150
+
?tls_config:Tls.Config.client ->
174
151
string ->
175
152
Response.t
176
-
(** HEAD request *)
153
+
(** HEAD request. See {!request} for parameter details. *)
177
154
178
155
val patch :
179
156
sw:Eio.Switch.t ->
180
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
157
+
clock:_ Eio.Time.clock ->
158
+
net:_ Eio.Net.t ->
181
159
?headers:Headers.t ->
182
160
?body:Body.t ->
183
161
?auth:Auth.t ->
184
162
?timeout:Timeout.t ->
163
+
?verify_tls:bool ->
164
+
?tls_config:Tls.Config.client ->
185
165
string ->
186
166
Response.t
187
-
(** PATCH request *)
167
+
(** PATCH request. See {!request} for parameter details. *)
188
168
189
169
val upload :
190
170
sw:Eio.Switch.t ->
191
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
171
+
clock:_ Eio.Time.clock ->
172
+
net:_ Eio.Net.t ->
192
173
?headers:Headers.t ->
193
174
?auth:Auth.t ->
194
175
?timeout:Timeout.t ->
···
196
177
?mime:Mime.t ->
197
178
?length:int64 ->
198
179
?on_progress:(sent:int64 -> total:int64 option -> unit) ->
180
+
?verify_tls:bool ->
181
+
?tls_config:Tls.Config.client ->
199
182
source:Eio.Flow.source_ty Eio.Resource.t ->
200
183
string ->
201
184
Response.t
202
-
(** Upload from stream *)
185
+
(** Upload from stream. See {!request} for parameter details. *)
203
186
204
187
val download :
205
188
sw:Eio.Switch.t ->
206
-
?client:(_ Eio.Time.clock , _ Eio.Net.t) t ->
189
+
clock:_ Eio.Time.clock ->
190
+
net:_ Eio.Net.t ->
207
191
?headers:Headers.t ->
208
192
?auth:Auth.t ->
209
193
?timeout:Timeout.t ->
210
194
?on_progress:(received:int64 -> total:int64 option -> unit) ->
195
+
?verify_tls:bool ->
196
+
?tls_config:Tls.Config.client ->
211
197
string ->
212
198
sink:Eio.Flow.sink_ty Eio.Resource.t ->
213
199
unit
214
-
(** Download to stream *)
200
+
(** Download to stream. See {!request} for parameter details. *)
+239
-80
stack/requests/lib/requests.ml
+239
-80
stack/requests/lib/requests.ml
···
21
21
We don't call use_default() here as it spawns background threads
22
22
that are incompatible with Eio's structured concurrency. *)
23
23
24
-
(* Main API - Session functionality with concurrent fiber spawning *)
24
+
(* Main API - Session functionality with connection pooling *)
25
25
26
26
type ('clock, 'net) t = {
27
27
sw : Eio.Switch.t;
28
-
client : ('clock, 'net) One.t;
29
28
clock : 'clock;
29
+
net : 'net;
30
+
31
+
(* Connection pools owned by this session *)
32
+
http_pool : ('clock, 'net) Conpool.t;
33
+
https_pool : ('clock, 'net) Conpool.t;
34
+
35
+
(* Session state - immutable *)
30
36
cookie_jar : Cookeio.jar;
31
37
cookie_mutex : Eio.Mutex.t;
32
-
mutable default_headers : Headers.t;
33
-
mutable auth : Auth.t option;
34
-
mutable timeout : Timeout.t;
35
-
mutable follow_redirects : bool;
36
-
mutable max_redirects : int;
37
-
mutable retry : Retry.config option;
38
+
default_headers : Headers.t;
39
+
auth : Auth.t option;
40
+
timeout : Timeout.t;
41
+
follow_redirects : bool;
42
+
max_redirects : int;
43
+
verify_tls : bool;
44
+
tls_config : Tls.Config.client option;
45
+
retry : Retry.config option;
38
46
persist_cookies : bool;
39
47
xdg : Xdge.t option;
40
48
cache : Cache.t option;
41
-
(* Statistics *)
49
+
50
+
(* Statistics - mutable for tracking across all derived sessions *)
42
51
mutable requests_made : int;
43
52
mutable total_time : float;
44
53
mutable retries_count : int;
···
46
55
47
56
let create
48
57
~sw
49
-
?client
58
+
?http_pool
59
+
?https_pool
50
60
?cookie_jar
51
61
?(default_headers = Headers.empty)
52
62
?auth
···
54
64
?(follow_redirects = true)
55
65
?(max_redirects = 10)
56
66
?(verify_tls = true)
67
+
?tls_config
68
+
?(max_connections_per_host = 10)
69
+
?(connection_idle_timeout = 60.0)
70
+
?(connection_lifetime = 300.0)
57
71
?retry
58
72
?(persist_cookies = false)
59
73
?(enable_cache = false)
60
74
?xdg
61
75
env =
62
76
77
+
let clock = env#clock in
78
+
let net = env#net in
79
+
63
80
let xdg = match xdg, persist_cookies || enable_cache with
64
81
| Some x, _ -> Some x
65
82
| None, true -> Some (Xdge.create env#fs "requests")
66
83
| None, false -> None
67
84
in
68
85
69
-
let client = match client with
70
-
| Some c -> c
86
+
(* Create TLS config for HTTPS pool if needed *)
87
+
let tls_config = match tls_config, verify_tls with
88
+
| Some cfg, _ -> Some cfg
89
+
| None, true ->
90
+
(* Use CA certificates for verification *)
91
+
(match Ca_certs.authenticator () with
92
+
| Ok authenticator ->
93
+
(match Tls.Config.client ~authenticator () with
94
+
| Ok cfg -> Some cfg
95
+
| Error (`Msg msg) ->
96
+
Log.warn (fun m -> m "Failed to create TLS config: %s" msg);
97
+
None)
98
+
| Error (`Msg msg) ->
99
+
Log.warn (fun m -> m "Failed to load CA certificates: %s" msg);
100
+
None)
101
+
| None, false -> None
102
+
in
103
+
104
+
(* Create connection pools if not provided *)
105
+
let pool_config = Conpool.Config.make
106
+
~max_connections_per_endpoint:max_connections_per_host
107
+
~max_idle_time:connection_idle_timeout
108
+
~max_connection_lifetime:connection_lifetime
109
+
()
110
+
in
111
+
112
+
(* HTTP pool - plain TCP connections *)
113
+
let http_pool = match http_pool with
114
+
| Some p -> p
71
115
| None ->
72
-
One.create ~sw ~verify_tls ~timeout
73
-
~clock:env#clock ~net:env#net ()
116
+
Conpool.create ~sw ~net ~clock ~config:pool_config ()
74
117
in
75
118
119
+
(* HTTPS pool - TLS-wrapped connections *)
120
+
let https_pool = match https_pool with
121
+
| Some p -> p
122
+
| None ->
123
+
let https_tls_config = Option.map (fun cfg ->
124
+
Conpool.Tls_config.make ~config:cfg ()
125
+
) tls_config in
126
+
Conpool.create ~sw ~net ~clock ?tls:https_tls_config ~config:pool_config ()
127
+
in
128
+
129
+
Log.info (fun m -> m "Created Requests session with connection pools (max_per_host=%d, TLS=%b)"
130
+
max_connections_per_host (Option.is_some tls_config));
131
+
76
132
let cookie_jar = match cookie_jar, persist_cookies, xdg with
77
133
| Some jar, _, _ -> jar
78
134
| None, true, Some xdg_ctx ->
···
95
151
96
152
{
97
153
sw;
98
-
client;
99
-
clock = env#clock;
154
+
clock;
155
+
net;
156
+
http_pool;
157
+
https_pool;
100
158
cookie_jar;
101
159
cookie_mutex = Eio.Mutex.create ();
102
160
default_headers;
···
104
162
timeout;
105
163
follow_redirects;
106
164
max_redirects;
165
+
verify_tls;
166
+
tls_config;
107
167
retry;
108
168
persist_cookies;
109
169
xdg;
···
113
173
retries_count = 0;
114
174
}
115
175
116
-
(* Configuration management *)
117
176
let set_default_header t key value =
118
-
t.default_headers <- Headers.set key value t.default_headers
177
+
{ t with default_headers = Headers.set key value t.default_headers }
119
178
120
179
let remove_default_header t key =
121
-
t.default_headers <- Headers.remove key t.default_headers
180
+
{ t with default_headers = Headers.remove key t.default_headers }
122
181
123
182
let set_auth t auth =
124
183
Log.debug (fun m -> m "Setting authentication method");
125
-
t.auth <- Some auth
184
+
{ t with auth = Some auth }
126
185
127
186
let clear_auth t =
128
187
Log.debug (fun m -> m "Clearing authentication");
129
-
t.auth <- None
188
+
{ t with auth = None }
130
189
131
190
let set_timeout t timeout =
132
191
Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout);
133
-
t.timeout <- timeout
192
+
{ t with timeout }
134
193
135
194
let set_retry t config =
136
195
Log.debug (fun m -> m "Setting retry config: max_retries=%d" config.Retry.max_retries);
137
-
t.retry <- Some config
196
+
{ t with retry = Some config }
138
197
139
198
let cookies t = t.cookie_jar
140
199
let clear_cookies t = Cookeio.clear t.cookie_jar
141
200
142
-
(* Internal request function that runs in a fiber *)
201
+
(* Internal request function using connection pools *)
143
202
let make_request_internal t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
144
-
Log.info (fun m -> m "Making %s request to %s" (Method.to_string method_) url);
203
+
let start_time = Unix.gettimeofday () in
204
+
let method_str = Method.to_string method_ in
205
+
206
+
Log.info (fun m -> m "Making %s request to %s" method_str url);
207
+
208
+
(* Parse URL *)
209
+
let uri = Uri.of_string url in
210
+
let domain = Option.value ~default:"" (Uri.host uri) in
211
+
let path = Uri.path uri in
212
+
let is_secure = Uri.scheme uri = Some "https" in
213
+
145
214
(* Merge headers *)
146
215
let headers = match headers with
147
216
| Some h -> Headers.merge t.default_headers h
···
154
223
| None -> t.auth
155
224
in
156
225
157
-
(* Get cookies for this URL *)
158
-
let uri = Uri.of_string url in
159
-
let domain = Option.value ~default:"" (Uri.host uri) in
160
-
let path = Uri.path uri in
161
-
let is_secure = Uri.scheme uri = Some "https" in
226
+
(* Apply auth *)
227
+
let headers = match auth with
228
+
| Some a ->
229
+
Log.debug (fun m -> m "Applying authentication");
230
+
Auth.apply a headers
231
+
| None -> headers
232
+
in
162
233
234
+
(* Add content type from body *)
235
+
let headers = match body with
236
+
| Some b -> (match Body.content_type b with
237
+
| Some mime -> Headers.content_type mime headers
238
+
| None -> headers)
239
+
| None -> headers
240
+
in
241
+
242
+
(* Get cookies for this URL *)
163
243
let headers =
164
244
Eio.Mutex.use_ro t.cookie_mutex (fun () ->
165
245
let cookies = Cookeio.get_cookies t.cookie_jar ~domain ~path ~is_secure in
···
172
252
)
173
253
in
174
254
255
+
(* Convert body to string for sending *)
256
+
let request_body_str = match body with
257
+
| None -> ""
258
+
| Some b -> Body.Private.to_string b
259
+
in
260
+
175
261
(* Check cache for GET and HEAD requests when body is not present *)
176
-
let response = match t.cache, method_, body with
262
+
let cached_response = match t.cache, method_, body with
177
263
| Some cache, (`GET | `HEAD), None ->
178
-
Log.debug (fun m -> m "Checking cache for %s request to %s" (Method.to_string method_) url);
264
+
Log.debug (fun m -> m "Checking cache for %s request to %s" method_str url);
179
265
let headers_cohttp = Cohttp.Header.of_list (Headers.to_list headers) in
180
-
(match Cache.get cache ~method_ ~url:uri ~headers:headers_cohttp with
181
-
| Some cached_response ->
182
-
Log.info (fun m -> m "Cache HIT for %s request to %s" (Method.to_string method_) url);
183
-
(* Convert cached response to Response.t *)
184
-
let status = Cohttp.Code.code_of_status cached_response.Cache.status in
185
-
let resp_headers = Headers.of_list (Cohttp.Header.to_list cached_response.Cache.headers) in
186
-
let body_flow = Eio.Flow.string_source cached_response.Cache.body in
187
-
Response.make ~sw:t.sw ~status ~headers:resp_headers ~body:body_flow ~url ~elapsed:0.0
188
-
| None ->
189
-
Log.info (fun m -> m "Cache MISS for %s request to %s" (Method.to_string method_) url);
190
-
(* Make the actual request *)
191
-
let response = One.request ~sw:t.sw ~client:t.client
192
-
?body ?auth
193
-
~timeout:(Option.value timeout ~default:t.timeout)
194
-
~follow_redirects:(Option.value follow_redirects ~default:t.follow_redirects)
195
-
~max_redirects:(Option.value max_redirects ~default:t.max_redirects)
196
-
~headers ~method_ url
197
-
in
198
-
(* Store in cache if successful *)
199
-
(match t.cache with
200
-
| Some cache when Response.ok response ->
201
-
Log.debug (fun m -> m "Storing response in cache for %s" url);
202
-
let status_code = Response.status_code response in
203
-
let status = Cohttp.Code.status_of_code status_code in
204
-
let resp_headers = Response.headers response in
205
-
let resp_headers_cohttp = Cohttp.Header.of_list (Headers.to_list resp_headers) in
206
-
(* Read body to cache it *)
207
-
let body_flow = Response.body response in
208
-
let buf = Buffer.create 4096 in
209
-
Eio.Flow.copy body_flow (Eio.Flow.buffer_sink buf);
210
-
let body_str = Buffer.contents buf in
211
-
Cache.put cache ~method_ ~url:uri ~request_headers:headers_cohttp
212
-
~status ~headers:resp_headers_cohttp ~body:body_str;
213
-
(* Return a new response with the buffered body *)
214
-
let new_body_flow = Eio.Flow.string_source body_str in
215
-
Response.make ~sw:t.sw ~status:status_code ~headers:resp_headers ~body:new_body_flow ~url ~elapsed:0.0
216
-
| _ -> response))
217
-
| _ ->
218
-
Log.debug (fun m -> m "Cache not applicable for %s request to %s (cache enabled: %b, body present: %b)"
219
-
(Method.to_string method_) url (Option.is_some t.cache) (Option.is_some body));
220
-
(* Make the actual request without caching *)
221
-
One.request ~sw:t.sw ~client:t.client
222
-
?body ?auth
223
-
~timeout:(Option.value timeout ~default:t.timeout)
224
-
~follow_redirects:(Option.value follow_redirects ~default:t.follow_redirects)
225
-
~max_redirects:(Option.value max_redirects ~default:t.max_redirects)
226
-
~headers ~method_ url
266
+
Cache.get cache ~method_ ~url:uri ~headers:headers_cohttp
267
+
| _ -> None
268
+
in
269
+
270
+
let response = match cached_response with
271
+
| Some cached ->
272
+
Log.info (fun m -> m "Cache HIT for %s request to %s" method_str url);
273
+
(* Convert cached response to Response.t *)
274
+
let status = Cohttp.Code.code_of_status cached.Cache.status in
275
+
let resp_headers = Headers.of_list (Cohttp.Header.to_list cached.Cache.headers) in
276
+
let body_flow = Eio.Flow.string_source cached.Cache.body in
277
+
Response.Private.make ~sw:t.sw ~status ~headers:resp_headers ~body:body_flow ~url ~elapsed:0.0
278
+
| None ->
279
+
Log.info (fun m -> m "Cache MISS or not applicable for %s request to %s" method_str url);
280
+
281
+
(* Execute request with redirect handling *)
282
+
let rec make_with_redirects url_to_fetch redirects_left =
283
+
let uri_to_fetch = Uri.of_string url_to_fetch in
284
+
285
+
(* Parse the redirect URL to get correct host and port *)
286
+
let redirect_host = match Uri.host uri_to_fetch with
287
+
| Some h -> h
288
+
| None -> failwith "Redirect URL must contain a host"
289
+
in
290
+
let redirect_port = match Uri.scheme uri_to_fetch, Uri.port uri_to_fetch with
291
+
| Some "https", None -> 443
292
+
| Some "https", Some p -> p
293
+
| Some "http", None -> 80
294
+
| Some "http", Some p -> p
295
+
| _, Some p -> p
296
+
| _ -> 80
297
+
in
298
+
299
+
(* Create endpoint for this specific URL *)
300
+
let redirect_endpoint = Conpool.Endpoint.make ~host:redirect_host ~port:redirect_port in
301
+
302
+
(* Determine if we need TLS based on this URL's scheme *)
303
+
let redirect_is_https = match Uri.scheme uri_to_fetch with
304
+
| Some "https" -> true
305
+
| _ -> false
306
+
in
307
+
308
+
(* Choose the appropriate connection pool for this URL *)
309
+
let redirect_pool = if redirect_is_https then t.https_pool else t.http_pool in
310
+
311
+
let make_request_fn () =
312
+
Conpool.with_connection redirect_pool redirect_endpoint (fun flow ->
313
+
(* Flow is already TLS-wrapped if from https_pool, plain TCP if from http_pool *)
314
+
(* Use our low-level HTTP client *)
315
+
Http_client.make_request ~method_:method_str ~uri:uri_to_fetch
316
+
~headers ~body_str:request_body_str flow
317
+
)
318
+
in
319
+
320
+
(* Apply timeout if specified *)
321
+
let status, resp_headers, response_body_str =
322
+
let timeout_val = Option.value timeout ~default:t.timeout in
323
+
match Timeout.total timeout_val with
324
+
| Some seconds ->
325
+
Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds);
326
+
Eio.Time.with_timeout_exn t.clock seconds make_request_fn
327
+
| None -> make_request_fn ()
328
+
in
329
+
330
+
Log.info (fun m -> m "Received response: status=%d" status);
331
+
332
+
(* Handle redirects if enabled *)
333
+
let follow = Option.value follow_redirects ~default:t.follow_redirects in
334
+
let max_redir = Option.value max_redirects ~default:t.max_redirects in
335
+
336
+
if follow && (status >= 300 && status < 400) then begin
337
+
if redirects_left <= 0 then begin
338
+
Log.err (fun m -> m "Too many redirects (%d) for %s" max_redir url);
339
+
raise (Error.TooManyRedirects { url; count = max_redir; max = max_redir })
340
+
end;
341
+
342
+
match Headers.get "location" resp_headers with
343
+
| None ->
344
+
Log.debug (fun m -> m "Redirect response missing Location header");
345
+
(status, resp_headers, response_body_str, url_to_fetch)
346
+
| Some location ->
347
+
Log.info (fun m -> m "Following redirect to %s (%d remaining)" location redirects_left);
348
+
make_with_redirects location (redirects_left - 1)
349
+
end else
350
+
(status, resp_headers, response_body_str, url_to_fetch)
351
+
in
352
+
353
+
let max_redir = Option.value max_redirects ~default:t.max_redirects in
354
+
let final_status, final_headers, final_body_str, final_url =
355
+
make_with_redirects url max_redir
356
+
in
357
+
358
+
let elapsed = Unix.gettimeofday () -. start_time in
359
+
Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
360
+
361
+
(* Store in cache if successful and caching enabled *)
362
+
(match t.cache with
363
+
| Some cache when final_status >= 200 && final_status < 300 ->
364
+
Log.debug (fun m -> m "Storing response in cache for %s" url);
365
+
let status = Cohttp.Code.status_of_code final_status in
366
+
let resp_headers_cohttp = Cohttp.Header.of_list (Headers.to_list final_headers) in
367
+
let headers_cohttp = Cohttp.Header.of_list (Headers.to_list headers) in
368
+
Cache.put cache ~method_ ~url:uri ~request_headers:headers_cohttp
369
+
~status ~headers:resp_headers_cohttp ~body:final_body_str
370
+
| _ -> ());
371
+
372
+
(* Create a flow from the body string *)
373
+
let body_flow = Eio.Flow.string_source final_body_str in
374
+
375
+
Response.Private.make
376
+
~sw:t.sw
377
+
~status:final_status
378
+
~headers:final_headers
379
+
~body:body_flow
380
+
~url:final_url
381
+
~elapsed
227
382
in
228
383
229
384
(* Extract and store cookies from response *)
···
246
401
247
402
(* Update statistics *)
248
403
t.requests_made <- t.requests_made + 1;
404
+
t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time);
249
405
Log.info (fun m -> m "Request completed with status %d" (Response.status_code response));
250
406
251
407
response
···
323
479
env in
324
480
325
481
(* Set user agent if provided *)
326
-
Option.iter (set_default_header req "User-Agent") config.user_agent;
482
+
let req = match config.user_agent with
483
+
| Some ua -> set_default_header req "User-Agent" ua
484
+
| None -> req
485
+
in
327
486
328
487
req
329
488
+43
-16
stack/requests/lib/requests.mli
+43
-16
stack/requests/lib/requests.mli
···
133
133
*)
134
134
135
135
type ('clock, 'net) t
136
-
(** A stateful HTTP client that maintains cookies, auth, and configuration across requests. *)
136
+
(** A stateful HTTP client that maintains cookies, auth, configuration, and
137
+
connection pools across requests. *)
137
138
138
139
(** {2 Creation and Configuration} *)
139
140
140
141
val create :
141
142
sw:Eio.Switch.t ->
142
-
?client:('clock Eio.Time.clock,'net Eio.Net.t) One.t ->
143
+
?http_pool:('clock Eio.Time.clock, 'net Eio.Net.t) Conpool.t ->
144
+
?https_pool:('clock Eio.Time.clock, 'net Eio.Net.t) Conpool.t ->
143
145
?cookie_jar:Cookeio.jar ->
144
146
?default_headers:Headers.t ->
145
147
?auth:Auth.t ->
···
147
149
?follow_redirects:bool ->
148
150
?max_redirects:int ->
149
151
?verify_tls:bool ->
152
+
?tls_config:Tls.Config.client ->
153
+
?max_connections_per_host:int ->
154
+
?connection_idle_timeout:float ->
155
+
?connection_lifetime:float ->
150
156
?retry:Retry.config ->
151
157
?persist_cookies:bool ->
152
158
?enable_cache:bool ->
153
159
?xdg:Xdge.t ->
154
160
< clock: 'clock Eio.Resource.t; net: 'net Eio.Resource.t; fs: Eio.Fs.dir_ty Eio.Path.t; .. > ->
155
161
('clock Eio.Resource.t, 'net Eio.Resource.t) t
156
-
(** Create a new requests instance with persistent state.
157
-
All resources are bound to the provided switch and will be cleaned up automatically. *)
162
+
(** Create a new requests instance with persistent state and connection pooling.
163
+
All resources are bound to the provided switch and will be cleaned up automatically.
164
+
165
+
@param sw Switch for resource management
166
+
@param http_pool Optional pre-configured HTTP connection pool (creates new if not provided)
167
+
@param https_pool Optional pre-configured HTTPS connection pool (creates new if not provided)
168
+
@param cookie_jar Cookie storage (default: empty in-memory jar)
169
+
@param default_headers Headers included in every request
170
+
@param auth Default authentication
171
+
@param timeout Default timeout configuration
172
+
@param follow_redirects Whether to follow HTTP redirects (default: true)
173
+
@param max_redirects Maximum redirects to follow (default: 10)
174
+
@param verify_tls Whether to verify TLS certificates (default: true)
175
+
@param tls_config Custom TLS configuration for HTTPS pool (default: system CA certs)
176
+
@param max_connections_per_host Maximum pooled connections per host:port (default: 10)
177
+
@param connection_idle_timeout Max idle time before closing pooled connection (default: 60s)
178
+
@param connection_lifetime Max lifetime of any pooled connection (default: 300s)
179
+
@param retry Retry configuration for failed requests
180
+
@param persist_cookies Whether to persist cookies to disk (default: false)
181
+
@param enable_cache Whether to enable HTTP caching (default: false)
182
+
@param xdg XDG directory context for cookies/cache (required if persist_cookies or enable_cache)
183
+
*)
158
184
159
185
(** {2 Configuration Management} *)
160
186
161
-
val set_default_header : ('clock, 'net) t -> string -> string -> unit
162
-
(** Set a default header for all requests *)
187
+
val set_default_header : ('clock, 'net) t -> string -> string -> ('clock, 'net) t
188
+
(** Add or update a default header. Returns a new session with the updated header.
189
+
The original session's connection pools are shared. *)
163
190
164
-
val remove_default_header : ('clock, 'net) t -> string -> unit
165
-
(** Remove a default header *)
191
+
val remove_default_header : ('clock, 'net) t -> string -> ('clock, 'net) t
192
+
(** Remove a default header. Returns a new session without the header. *)
166
193
167
-
val set_auth : ('clock, 'net) t -> Auth.t -> unit
168
-
(** Set default authentication *)
194
+
val set_auth : ('clock, 'net) t -> Auth.t -> ('clock, 'net) t
195
+
(** Set default authentication. Returns a new session with auth configured. *)
169
196
170
-
val clear_auth : ('clock, 'net) t -> unit
171
-
(** Clear authentication *)
197
+
val clear_auth : ('clock, 'net) t -> ('clock, 'net) t
198
+
(** Clear authentication. Returns a new session without auth. *)
172
199
173
-
val set_timeout : ('clock, 'net) t -> Timeout.t -> unit
174
-
(** Set default timeout *)
200
+
val set_timeout : ('clock, 'net) t -> Timeout.t -> ('clock, 'net) t
201
+
(** Set default timeout. Returns a new session with the timeout configured. *)
175
202
176
-
val set_retry : ('clock, 'net) t -> Retry.config -> unit
177
-
(** Set retry configuration *)
203
+
val set_retry : ('clock, 'net) t -> Retry.config -> ('clock, 'net) t
204
+
(** Set retry configuration. Returns a new session with retry configured. *)
178
205
179
206
(** {2 Request Methods}
180
207
+12
-23
stack/requests/test/test_connection_pool.ml
+12
-23
stack/requests/test/test_connection_pool.ml
···
1
-
(** Test connection pooling with conpool integration *)
1
+
(** Test stateless One API - each request opens a fresh connection *)
2
2
3
3
open Eio.Std
4
4
5
-
let test_connection_pooling () =
5
+
let test_one_stateless () =
6
6
(* Initialize RNG for TLS *)
7
7
Mirage_crypto_rng_unix.use_default ();
8
8
9
9
Eio_main.run @@ fun env ->
10
10
Switch.run @@ fun sw ->
11
11
12
-
(* Configure logging to see connection pool activity *)
12
+
(* Configure logging to see One request activity *)
13
13
Logs.set_reporter (Logs_fmt.reporter ());
14
14
Logs.set_level (Some Logs.Info);
15
-
Logs.Src.set_level Conpool.src (Some Logs.Info);
16
15
Logs.Src.set_level Requests.One.src (Some Logs.Info);
17
16
18
-
traceln "=== Testing Connection Pooling ===\n";
17
+
traceln "=== Testing One Stateless API ===\n";
18
+
traceln "The One API creates fresh connections for each request (no pooling)\n";
19
19
20
-
(* Create a client with connection pooling *)
21
-
let client = Requests.One.create
22
-
~sw
23
-
~clock:env#clock
24
-
~net:env#net
25
-
~max_connections_per_host:5
26
-
~connection_idle_timeout:30.0
27
-
~verify_tls:true
28
-
()
29
-
in
30
-
31
-
traceln "Client created with connection pool";
32
-
traceln "Making 10 requests to example.com...\n";
33
-
34
-
(* Make multiple requests to the same host *)
20
+
(* Make multiple requests to the same host using stateless One API *)
35
21
let start_time = Unix.gettimeofday () in
36
22
37
23
for i = 1 to 10 do
38
24
traceln "Request %d:" i;
39
-
let response = Requests.One.get ~sw ~client "http://example.com" in
25
+
let response = Requests.One.get ~sw
26
+
~clock:env#clock ~net:env#net
27
+
"http://example.com"
28
+
in
40
29
41
30
traceln " Status: %d" (Requests.Response.status_code response);
42
31
traceln " Content-Length: %s"
···
44
33
| Some len -> Int64.to_string len
45
34
| None -> "unknown");
46
35
47
-
(* Body already drained - connection automatically returned to pool *)
36
+
(* Connection is fresh for each request - no pooling *)
48
37
traceln ""
49
38
done;
50
39
···
56
45
57
46
let () =
58
47
try
59
-
test_connection_pooling ()
48
+
test_one_stateless ()
60
49
with e ->
61
50
traceln "Test failed with exception: %s" (Printexc.to_string e);
62
51
Printexc.print_backtrace stdout;
+7
-5
stack/requests/test/test_requests.ml
+7
-5
stack/requests/test/test_requests.ml
···
705
705
end in
706
706
Test_server.start_server ~port test_env;
707
707
708
-
let client = Requests.One.create ~sw ~clock:env#clock ~net:env#net () in
709
-
let response = Requests.One.get ~sw ~client (base_url ^ "/echo") in
708
+
let response = Requests.One.get ~sw
709
+
~clock:env#clock ~net:env#net
710
+
(base_url ^ "/echo")
711
+
in
710
712
711
713
Alcotest.(check int) "One module status" 200 (Requests.Response.status_code response)
712
714
···
815
817
816
818
let req = Requests.create ~sw env in
817
819
818
-
Requests.set_default_header req "X-Session" "session-123";
820
+
let req = Requests.set_default_header req "X-Session" "session-123" in
819
821
820
822
let auth = Requests.Auth.bearer ~token:"test_token" in
821
-
Requests.set_auth req auth;
823
+
let req = Requests.set_auth req auth in
822
824
823
825
let response1 = Requests.get req (base_url ^ "/echo") in
824
826
let body_str1 = Requests.Response.body response1 |> Eio.Flow.read_all in
···
834
836
835
837
Alcotest.(check string) "Session header persisted" "session-123" session_header;
836
838
837
-
Requests.remove_default_header req "X-Session";
839
+
let req = Requests.remove_default_header req "X-Session" in
838
840
839
841
let response2 = Requests.get req (base_url ^ "/echo") in
840
842
let body_str2 = Requests.Response.body response2 |> Eio.Flow.read_all in
+4
stack/typesense-cliente/dune
+4
stack/typesense-cliente/dune
+18
stack/typesense-cliente/dune-project
+18
stack/typesense-cliente/dune-project
···
1
+
(lang dune 3.0)
2
+
(name typesense-cliente)
3
+
(version 0.1.0)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(package
8
+
(name typesense-cliente)
9
+
(synopsis "Typesense search API client for OCaml using Eio")
10
+
(description "An Eio-based OCaml client library for Typesense search engine")
11
+
(depends
12
+
(ocaml (>= 4.14))
13
+
eio
14
+
requests
15
+
ezjsonm
16
+
fmt
17
+
uri
18
+
ptime))
+30
stack/typesense-cliente/typesense-cliente.opam
+30
stack/typesense-cliente/typesense-cliente.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
version: "0.1.0"
4
+
synopsis: "Typesense search API client for OCaml using Eio"
5
+
description: "An Eio-based OCaml client library for Typesense search engine"
6
+
depends: [
7
+
"dune" {>= "3.0"}
8
+
"ocaml" {>= "4.14"}
9
+
"eio"
10
+
"requests"
11
+
"ezjsonm"
12
+
"fmt"
13
+
"uri"
14
+
"ptime"
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
+
]
+85
stack/typesense-cliente/typesense_cliente.mli
+85
stack/typesense-cliente/typesense_cliente.mli
···
1
+
(** Typesense client for OCaml using Eio and Requests *)
2
+
3
+
(** Configuration for Typesense client *)
4
+
type config = {
5
+
endpoint : string;
6
+
api_key : string;
7
+
}
8
+
9
+
(** Error types for Typesense operations *)
10
+
type error =
11
+
| Http_error of int * string
12
+
| Json_error of string
13
+
| Connection_error of string
14
+
15
+
val pp_error : Format.formatter -> error -> unit
16
+
17
+
(** Search result types *)
18
+
type search_result = {
19
+
id: string;
20
+
title: string;
21
+
content: string;
22
+
score: float;
23
+
collection: string;
24
+
highlights: (string * string list) list;
25
+
document: Ezjsonm.value; (* Store raw document for flexible field access *)
26
+
}
27
+
28
+
type search_response = {
29
+
hits: search_result list;
30
+
total: int;
31
+
query_time: float;
32
+
}
33
+
34
+
(** Multisearch result types *)
35
+
type multisearch_response = {
36
+
results: search_response list;
37
+
}
38
+
39
+
(** Search a single collection *)
40
+
val search_collection :
41
+
sw:Eio.Switch.t ->
42
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
43
+
config ->
44
+
string ->
45
+
string ->
46
+
?limit:int ->
47
+
?offset:int ->
48
+
unit ->
49
+
(search_response, error) result
50
+
51
+
(** Perform multisearch across all collections *)
52
+
val multisearch :
53
+
sw:Eio.Switch.t ->
54
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
55
+
config ->
56
+
string ->
57
+
?limit:int ->
58
+
unit ->
59
+
(multisearch_response, error) result
60
+
61
+
(** Combine multisearch results into single result set *)
62
+
val combine_multisearch_results :
63
+
multisearch_response ->
64
+
?limit:int ->
65
+
?offset:int ->
66
+
unit ->
67
+
search_response
68
+
69
+
(** List all collections *)
70
+
val list_collections :
71
+
sw:Eio.Switch.t ->
72
+
env:< clock: [> float Eio.Time.clock_ty ] Eio.Resource.t; net: [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; .. > ->
73
+
config ->
74
+
((string * int) list, error) result
75
+
76
+
(** Pretty printer utilities *)
77
+
val extract_field_string : Ezjsonm.value -> string -> string
78
+
val extract_field_string_list : Ezjsonm.value -> string -> string list
79
+
val extract_field_bool : Ezjsonm.value -> string -> bool
80
+
val format_authors : string list -> string
81
+
val format_date : string -> string
82
+
val format_tags : string list -> string
83
+
84
+
(** One-line pretty printer for search results *)
85
+
val pp_search_result_oneline : search_result -> string
+1
-1
stack/zotero-translation/dune
+1
-1
stack/zotero-translation/dune
+66
-68
stack/zotero-translation/zotero_translation.ml
+66
-68
stack/zotero-translation/zotero_translation.ml
···
1
1
(** Resolve a DOI from a Zotero translation server *)
2
2
3
-
module C = Cohttp
4
-
module CL = Cohttp_lwt
5
-
module CLU = Cohttp_lwt_unix.Client
6
3
module J = Ezjsonm
7
4
8
5
(* From the ZTS source code: https://github.com/zotero/translation-server/blob/master/src/formats.js
···
102
99
| true -> Uri.of_string (base_uri ^ "import")
103
100
| false -> Uri.of_string (base_uri ^ "/import")
104
101
105
-
open Lwt.Infix
106
-
107
-
(* The Eio version has more in here, hence I'm just keeping this around. *)
108
-
type t = {
102
+
type ('clock, 'net) t = {
109
103
base_uri: string;
104
+
requests_session: ('clock, 'net) Requests.t;
110
105
}
111
106
112
-
let v base_uri = { base_uri }
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
112
+
{ base_uri; requests_session }
113
113
114
-
let resolve_doi { base_uri } doi =
115
-
let body = "https://doi.org/" ^ doi in
116
-
let doi_body = CL.Body.of_string body in
117
-
let headers = C.Header.init_with "content-type" "text/plain" in
114
+
let v _base_uri =
115
+
failwith "Zotero_translation.v is deprecated. Use Zotero_translation.create ~sw ~env base_uri instead"
116
+
117
+
let resolve_doi { base_uri; requests_session } doi =
118
+
let body_str = "https://doi.org/" ^ doi in
118
119
let uri = web_endp base_uri in
119
-
CLU.call ~headers ~body:doi_body `POST uri >>= fun (resp, body) ->
120
-
let status = C.Response.status resp in
121
-
body |> Cohttp_lwt.Body.to_string >>= fun body ->
122
-
if status = `OK then begin
120
+
let body = Requests.Body.text body_str in
121
+
let response = Requests.post requests_session ~body (Uri.to_string uri) in
122
+
let status = Requests.Response.status_code response in
123
+
let body = Requests.Response.body response |> Eio.Flow.read_all in
124
+
if status = 200 then begin
123
125
try
124
126
let doi_json = J.from_string body in
125
-
Lwt.return_ok doi_json
126
-
with exn -> Lwt.return_error (`Msg (Printexc.to_string exn))
127
+
Ok doi_json
128
+
with exn -> Error (`Msg (Printexc.to_string exn))
127
129
end else
128
-
Lwt.return_error (`Msg (Format.asprintf "Unexpected HTTP status: %a for %s" Http.Status.pp status body))
130
+
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
129
131
130
-
let resolve_url { base_uri } url =
131
-
let url_body = CL.Body.of_string url in
132
-
let headers = C.Header.init_with "content-type" "text/plain" in
132
+
let resolve_url { base_uri; requests_session } url =
133
+
let body_str = url in
133
134
let uri = web_endp base_uri in
134
-
CLU.call ~headers ~body:url_body `POST uri >>= fun (resp, body) ->
135
-
let status = C.Response.status resp in
136
-
body |> Cohttp_lwt.Body.to_string >>= fun body ->
137
-
if status = `OK then begin
135
+
let body = Requests.Body.text body_str in
136
+
let response = Requests.post requests_session ~body (Uri.to_string uri) in
137
+
let status = Requests.Response.status_code response in
138
+
let body = Requests.Response.body response |> Eio.Flow.read_all in
139
+
if status = 200 then begin
138
140
try
139
141
let url_json = J.from_string body in
140
-
Lwt.return_ok url_json
141
-
with exn -> Lwt.return_error (`Msg (Printexc.to_string exn))
142
+
Ok url_json
143
+
with exn -> Error (`Msg (Printexc.to_string exn))
142
144
end else
143
-
Lwt.return_error (`Msg (Format.asprintf "Unexpected HTTP status: %a for %s" Http.Status.pp status body))
145
+
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
144
146
145
-
let search_id { base_uri} doi =
146
-
let body = "https://doi.org/" ^ doi in
147
-
let doi_body = CL.Body.of_string body in
148
-
let headers = C.Header.init_with "content-type" "text/plain" in
147
+
let search_id { base_uri; requests_session } doi =
148
+
let body_str = "https://doi.org/" ^ doi in
149
149
let uri = search_endp base_uri in
150
-
CLU.call ~headers ~body:doi_body `POST uri >>= fun (resp, body) ->
151
-
let status = C.Response.status resp in
152
-
body |> Cohttp_lwt.Body.to_string >>= fun body ->
153
-
if status = `OK then begin
150
+
let body = Requests.Body.text body_str in
151
+
let response = Requests.post requests_session ~body (Uri.to_string uri) in
152
+
let status = Requests.Response.status_code response in
153
+
let body = Requests.Response.body response |> Eio.Flow.read_all in
154
+
if status = 200 then begin
154
155
try
155
156
let doi_json = J.from_string body in
156
-
Lwt.return_ok doi_json
157
-
with exn -> Lwt.return_error (`Msg (Printexc.to_string exn))
157
+
Ok doi_json
158
+
with exn -> Error (`Msg (Printexc.to_string exn))
158
159
end else
159
-
Lwt.return_error (`Msg (Format.asprintf "Unexpected HTTP status: %a for %s" Http.Status.pp status body))
160
+
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
160
161
161
-
let export {base_uri} format api =
162
-
let body = CL.Body.of_string (J.to_string api) in
163
-
let headers = C.Header.init_with "content-type" "application/json" in
162
+
let export { base_uri; requests_session } format api =
163
+
let body_str = J.to_string api in
164
164
let uri = Uri.with_query' (export_endp base_uri ) ["format", (format_to_string format)] in
165
-
CLU.call ~headers ~body `POST uri >>= fun (resp, body) ->
166
-
let status = C.Response.status resp in
167
-
body |> Cohttp_lwt.Body.to_string >>= fun body ->
168
-
if status = `OK then begin
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
169
170
try
170
171
match format with
171
-
| Bibtex -> Lwt.return_ok (Astring.String.trim body)
172
-
| _ -> Lwt.return_ok body
173
-
with exn -> Lwt.return_error (`Msg (Printexc.to_string exn))
172
+
| Bibtex -> Ok (Astring.String.trim body)
173
+
| _ -> Ok body
174
+
with exn -> Error (`Msg (Printexc.to_string exn))
174
175
end else
175
-
Lwt.return_error (`Msg (Format.asprintf "Unexpected HTTP status: %a for %s" Http.Status.pp status body))
176
+
Error (`Msg (Format.asprintf "Unexpected HTTP status: %d for %s" status body))
176
177
177
178
let unescape_hex s =
178
179
let buf = Buffer.create (String.length s) in
···
201
202
| Error e ->
202
203
prerr_endline bib;
203
204
Fmt.epr "%a\n%!" Bibtex.pp_error e;
204
-
Lwt.fail_with "bib parse err TODO"
205
+
failwith "bib parse err TODO"
205
206
| Ok [bib] ->
206
207
let f = Bibtex.fields bib |> Bibtex.SM.bindings |> List.map (fun (k,v) -> k, (unescape_bibtex v)) in
207
208
let ty = match Bibtex.type' bib with "inbook" -> "book" | x -> x in
208
209
let v = List.fold_left (fun acc (k,v) -> (k,(`String v))::acc) ["bibtype",`String ty] f in
209
-
Lwt.return v
210
-
| Ok _ -> Lwt.fail_with "one bib at a time plz"
210
+
v
211
+
| Ok _ -> failwith "one bib at a time plz"
211
212
212
213
let bib_of_doi zt doi =
213
214
prerr_endline ("Fetching " ^ doi);
214
-
let v = resolve_doi zt doi >>= function
215
-
| Ok r ->
216
-
Lwt.return r
215
+
let v = match resolve_doi zt doi with
216
+
| Ok r -> r
217
217
| Error (`Msg _) ->
218
218
Printf.eprintf "%s failed on /web, trying to /search\n%!" doi;
219
-
search_id zt doi >>= function
220
-
| Error (`Msg e) -> Lwt.fail_with e
221
-
| Ok r ->
222
-
Lwt.return r
219
+
match search_id zt doi with
220
+
| Error (`Msg e) -> failwith e
221
+
| Ok r -> r
223
222
in
224
-
v >>= fun v ->
225
-
export zt Bibtex v >>= function
226
-
| Error (`Msg e) -> Lwt.fail_with e
223
+
match export zt Bibtex v with
224
+
| Error (`Msg e) -> failwith e
227
225
| Ok r ->
228
226
print_endline r;
229
-
Lwt.return r
227
+
r
230
228
231
229
let split_authors keys =
232
230
let authors =
···
270
268
fun bib -> J.update y ["bib"] (Some (`String bib))
271
269
272
270
let json_of_doi zt ~slug doi =
273
-
bib_of_doi zt doi >>= fun x ->
274
-
fields_of_bib x >>= fun x ->
275
-
Lwt.return (split_authors x |> add_bibtex ~slug)
271
+
let x = bib_of_doi zt doi in
272
+
let x = fields_of_bib x in
273
+
split_authors x |> add_bibtex ~slug
+25
-7
stack/zotero-translation/zotero_translation.mli
+25
-7
stack/zotero-translation/zotero_translation.mli
···
1
1
(** {1 Interface to the Zotero Translation Server} *)
2
2
3
-
type t
3
+
type ('clock, 'net) t
4
4
5
5
type format =
6
6
| Bibtex
···
24
24
val format_to_string: format -> string
25
25
val format_of_string: string -> format option
26
26
27
-
val v : string -> t
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. *)
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 ->
36
+
string -> ('clock Eio.Resource.t, 'net Eio.Resource.t) t
28
37
29
-
val resolve_doi: t -> string -> ([>Ezjsonm.t], [>`Msg of string]) Lwt_result.t
38
+
(** Deprecated: use [create] instead *)
39
+
val v : string -> (_, _) t
40
+
[@@deprecated "Use create ~sw ~env base_uri instead"]
30
41
31
-
val resolve_url: t -> string -> ([>Ezjsonm.t], [>`Msg of string]) Lwt_result.t
42
+
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
32
44
33
-
val search_id: t -> string -> ([>Ezjsonm.t], [>`Msg of string]) Lwt_result.t
45
+
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
34
47
35
-
val export: t -> format -> Ezjsonm.t -> (string, [>`Msg of string]) Lwt_result.t
48
+
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
36
50
37
-
val json_of_doi : t -> slug:string -> string -> Ezjsonm.value Lwt.t
51
+
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
53
+
54
+
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