My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "requests.body" ~doc:"HTTP Request/Response Body"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4type 'a part = {
5 name : string;
6 filename : string option;
7 content_type : Mime.t;
8 content : [`String of string | `Stream of Eio.Flow.source_ty Eio.Resource.t | `File of 'a Eio.Path.t];
9}
10
11type t =
12 | Empty
13 | String of { content : string; mime : Mime.t }
14 | Stream of { source : Eio.Flow.source_ty Eio.Resource.t; mime : Mime.t; length : int64 option }
15 | File : { file : 'a Eio.Path.t; mime : Mime.t } -> t
16 | Multipart : { parts : 'a part list; boundary : string } -> t
17
18let empty = Empty
19
20let of_string mime content =
21 String { content; mime }
22
23let of_stream ?length mime source =
24 Stream { source; mime; length }
25
26let of_file ?mime file =
27 let mime = match mime with
28 | Some m -> m
29 | None ->
30 (* Guess MIME type from filename if available *)
31 let path = Eio.Path.native_exn file in
32 let guessed =
33 if String.ends_with ~suffix:".json" path then Mime.json
34 else if String.ends_with ~suffix:".html" path then Mime.html
35 else if String.ends_with ~suffix:".xml" path then Mime.xml
36 else if String.ends_with ~suffix:".txt" path then Mime.text
37 else Mime.octet_stream
38 in
39 Log.debug (fun m -> m "Guessed MIME type %s for file %s" (Mime.to_string guessed) path);
40 guessed
41 in
42 Log.debug (fun m -> m "Creating file body from %s with MIME type %s"
43 (Eio.Path.native_exn file) (Mime.to_string mime));
44 File { file; mime }
45
46(* For simple JSON encoding, we just take a Jsont.json value and encode it *)
47let json (json_value : Jsont.json) =
48 let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with
49 | Ok s -> s
50 | Error e ->
51 let msg = Jsont.Error.to_string e in
52 failwith (Printf.sprintf "Failed to encode JSON: %s" msg)
53 in
54 String { content; mime = Mime.json }
55
56(* JSON streaming using jsont - we encode the value to string and stream it *)
57module Json_stream_source = struct
58 type t = {
59 mutable content : string;
60 mutable offset : int;
61 }
62
63 let single_read t dst =
64 if t.offset >= String.length t.content then
65 raise End_of_file
66 else begin
67 let available = String.length t.content - t.offset in
68 let to_copy = min (Cstruct.length dst) available in
69 Cstruct.blit_from_string t.content t.offset dst 0 to_copy;
70 t.offset <- t.offset + to_copy;
71 to_copy
72 end
73
74 let read_methods = []
75end
76
77let json_stream_source_create json_value =
78 (* Encode the entire JSON value to string with minified format *)
79 let content = match Jsont_bytesrw.encode_string' ~format:Jsont.Minify Jsont.json json_value with
80 | Ok s -> s
81 | Error e ->
82 let msg = Jsont.Error.to_string e in
83 failwith (Printf.sprintf "Failed to encode JSON stream: %s" msg)
84 in
85 let t = { Json_stream_source.content; offset = 0 } in
86 let ops = Eio.Flow.Pi.source (module Json_stream_source) in
87 Eio.Resource.T (t, ops)
88
89let json_stream json_value =
90 let source = json_stream_source_create json_value in
91 Stream { source; mime = Mime.json; length = None }
92
93let text content =
94 String { content; mime = Mime.text }
95
96let form params =
97 let encode_param (k, v) =
98 Printf.sprintf "%s=%s"
99 (Uri.pct_encode ~component:`Query_value k)
100 (Uri.pct_encode ~component:`Query_value v)
101 in
102 let content = String.concat "&" (List.map encode_param params) in
103 String { content; mime = Mime.form }
104
105let generate_boundary () =
106 let random_bytes = Mirage_crypto_rng.generate 16 in
107 let random_part =
108 Cstruct.to_hex_string (Cstruct.of_string random_bytes)
109 in
110 Printf.sprintf "----WebKitFormBoundary%s" random_part
111
112let multipart parts =
113 let boundary = generate_boundary () in
114 Multipart { parts; boundary }
115
116let content_type = function
117 | Empty -> None
118 | String { mime; _ } -> Some mime
119 | Stream { mime; _ } -> Some mime
120 | File { mime; _ } -> Some mime
121 | Multipart { boundary; _ } ->
122 let mime = Mime.make "multipart" "form-data" in
123 Some (Mime.with_charset boundary mime)
124
125let content_length = function
126 | Empty -> Some 0L
127 | String { content; _ } -> Some (Int64.of_int (String.length content))
128 | Stream { length; _ } -> length
129 | File { file; _ } ->
130 (* Try to get file size *)
131 (try
132 let stat = Eio.Path.stat ~follow:true file in
133 Some (Optint.Int63.to_int64 stat.size)
134 with _ -> None)
135 | Multipart _ ->
136 (* Complex to calculate, handled during sending *)
137 None
138
139(* Strings_source - A flow source that streams from a doubly-linked list of strings/flows *)
140module Strings_source = struct
141 type element =
142 | String of string
143 | Flow of Eio.Flow.source_ty Eio.Resource.t
144
145 type t = {
146 dllist : element Lwt_dllist.t;
147 mutable current_element : element option;
148 mutable string_offset : int;
149 }
150
151 let rec single_read t dst =
152 match t.current_element with
153 | None ->
154 (* Try to get the first element from the list *)
155 if Lwt_dllist.is_empty t.dllist then
156 raise End_of_file
157 else begin
158 t.current_element <- Some (Lwt_dllist.take_l t.dllist);
159 single_read t dst
160 end
161 | Some (String s) when t.string_offset >= String.length s ->
162 (* Current string exhausted, move to next element *)
163 t.current_element <- None;
164 t.string_offset <- 0;
165 single_read t dst
166 | Some (String s) ->
167 (* Read from current string *)
168 let available = String.length s - t.string_offset in
169 let to_read = min (Cstruct.length dst) available in
170 Cstruct.blit_from_string s t.string_offset dst 0 to_read;
171 t.string_offset <- t.string_offset + to_read;
172 to_read
173 | Some (Flow flow) ->
174 (* Read from flow *)
175 (try
176 let n = Eio.Flow.single_read flow dst in
177 if n = 0 then begin
178 (* Flow exhausted, move to next element *)
179 t.current_element <- None;
180 single_read t dst
181 end else n
182 with End_of_file ->
183 t.current_element <- None;
184 single_read t dst)
185
186 let read_methods = [] (* No special read methods *)
187
188 let create () = {
189 dllist = Lwt_dllist.create ();
190 current_element = None;
191 string_offset = 0;
192 }
193
194 let add_string t s =
195 ignore (Lwt_dllist.add_r (String s) t.dllist)
196
197 let add_flow t flow =
198 ignore (Lwt_dllist.add_r (Flow flow) t.dllist)
199end
200
201let strings_source_create () =
202 let t = Strings_source.create () in
203 let ops = Eio.Flow.Pi.source (module Strings_source) in
204 (t, Eio.Resource.T (t, ops))
205
206let to_cohttp_body ~sw = function
207 | Empty -> None
208 | String { content; _ } -> Some (Cohttp_eio.Body.of_string content)
209 | Stream { source; _ } -> Some source
210 | File { file; _ } ->
211 (* Open file and stream it directly without loading into memory *)
212 let flow = Eio.Path.open_in ~sw file in
213 Some (flow :> Eio.Flow.source_ty Eio.Resource.t)
214 | Multipart { parts; boundary } ->
215 (* Create a single strings_source with dllist for streaming *)
216 let source, flow = strings_source_create () in
217
218 List.iter (fun part ->
219 (* Add boundary *)
220 Strings_source.add_string source "--";
221 Strings_source.add_string source boundary;
222 Strings_source.add_string source "\r\n";
223
224 (* Add Content-Disposition header *)
225 Strings_source.add_string source "Content-Disposition: form-data; name=\"";
226 Strings_source.add_string source part.name;
227 Strings_source.add_string source "\"";
228 (match part.filename with
229 | Some f ->
230 Strings_source.add_string source "; filename=\"";
231 Strings_source.add_string source f;
232 Strings_source.add_string source "\""
233 | None -> ());
234 Strings_source.add_string source "\r\n";
235
236 (* Add Content-Type header *)
237 Strings_source.add_string source "Content-Type: ";
238 Strings_source.add_string source (Mime.to_string part.content_type);
239 Strings_source.add_string source "\r\n\r\n";
240
241 (* Add content *)
242 (match part.content with
243 | `String s ->
244 Strings_source.add_string source s
245 | `File file ->
246 (* Open file and add as flow *)
247 let file_flow = Eio.Path.open_in ~sw file in
248 Strings_source.add_flow source (file_flow :> Eio.Flow.source_ty Eio.Resource.t)
249 | `Stream stream ->
250 (* Add stream directly *)
251 Strings_source.add_flow source stream);
252
253 (* Add trailing newline *)
254 Strings_source.add_string source "\r\n"
255 ) parts;
256
257 (* Add final boundary *)
258 Strings_source.add_string source "--";
259 Strings_source.add_string source boundary;
260 Strings_source.add_string source "--\r\n";
261
262 Some flow
263
264(* Private module *)
265module Private = struct
266 let to_cohttp_body = to_cohttp_body
267
268 let to_string = function
269 | Empty -> ""
270 | String { content; _ } -> content
271 | Stream _ -> failwith "Cannot convert streaming body to string for connection pooling (body must be materialized first)"
272 | File _ -> failwith "Cannot convert file body to string for connection pooling (file must be read first)"
273 | Multipart _ -> failwith "Cannot convert multipart body to string for connection pooling (must be encoded first)"
274
275 let _ = to_string (* Use to avoid warning *)
276end