gazagnaire.org
forked from
anil.recoil.org/ocaml-requests
A batteries included HTTP/1.1 client in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6let src = Logs.Src.create "requests.response" ~doc:"HTTP Response"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10type t = {
11 status : int;
12 headers : Headers.t;
13 body : Eio.Flow.source_ty Eio.Resource.t;
14 url : string;
15 elapsed : float;
16 mutable closed : bool;
17}
18
19let v ~sw ~status ~headers ~body ~url ~elapsed =
20 Log.debug (fun m ->
21 m "Creating response: status=%d url=%s elapsed=%.3fs" status url elapsed);
22 let response = { status; headers; body; url; elapsed; closed = false } in
23
24 (* Register cleanup with switch *)
25 Eio.Switch.on_release sw (fun () ->
26 if not response.closed then begin
27 Log.debug (fun m -> m "Auto-closing response for %s via switch" url);
28 response.closed <- true
29 (* Body cleanup happens automatically via Eio switch lifecycle.
30 The body flow (created via Eio.Flow.string_source) is a memory-backed
31 source that doesn't require explicit cleanup. File-based responses
32 would have their file handles cleaned up by the switch. *)
33 end);
34
35 response
36
37let status t = Status.of_int t.status
38let status_code t = t.status
39let ok t = Status.is_success (Status.of_int t.status)
40let headers t = t.headers
41let header name t = Headers.find name t.headers
42let header_string name t = Headers.string name t.headers
43
44(** Option monad operators for cleaner code *)
45let ( let* ) = Option.bind
46
47let ( let+ ) x f = Option.map f x
48
49let content_type t =
50 let+ ct = Headers.find `Content_type t.headers in
51 Mime.of_string ct
52
53let content_length t =
54 let* len = Headers.find `Content_length t.headers in
55 try Some (Int64.of_string len) with Failure _ -> None
56
57let location t = Headers.find `Location t.headers
58
59(** {1 Conditional Request / Caching Headers}
60
61 Per Recommendation #19: Conditional Request Helpers (ETag/Last-Modified) RFC
62 9110 Section 8.8.2-8.8.3 *)
63
64let etag t = Headers.find `Etag t.headers
65let last_modified t = Headers.find `Last_modified t.headers
66let parse_http_date = Http_date.parse
67
68let last_modified_ptime t =
69 let* lm = last_modified t in
70 Http_date.parse lm
71
72let date t = Headers.find `Date t.headers
73
74let date_ptime t =
75 let* d = date t in
76 Http_date.parse d
77
78let expires t = Headers.find `Expires t.headers
79
80let expires_ptime t =
81 let* exp = expires t in
82 Http_date.parse exp
83
84let age t =
85 let* s = Headers.find `Age t.headers in
86 try Some (int_of_string s) with Failure _ -> None
87
88(** {1 Cache-Control Parsing}
89
90 Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
91
92let cache_control t =
93 Option.map Cache_control.parse_response
94 (Headers.find `Cache_control t.headers)
95
96let cache_control_raw t = Headers.find `Cache_control t.headers
97
98(** Check if response is cacheable based on status and Cache-Control *)
99let is_cacheable t =
100 match cache_control t with
101 | Some cc -> Cache_control.is_cacheable ~response_cc:cc ~status:t.status
102 | None ->
103 (* No Cache-Control - use default cacheability based on status *)
104 List.mem t.status
105 [ 200; 203; 204; 206; 300; 301; 308; 404; 405; 410; 414; 501 ]
106
107(** Calculate freshness lifetime in seconds *)
108let freshness_lifetime t =
109 match cache_control t with
110 | Some cc ->
111 Cache_control.freshness_lifetime ~response_cc:cc ?expires:(expires t)
112 ?date:(date t) ()
113 | None -> None
114
115(** Check if response requires revalidation before use *)
116let must_revalidate t =
117 match cache_control t with
118 | Some cc -> Cache_control.must_revalidate ~response_cc:cc
119 | None -> false
120
121(** Check if response is stale (current time exceeds freshness) Requires the
122 current time as a parameter *)
123let is_stale ~now t =
124 match (freshness_lifetime t, date_ptime t) with
125 | Some lifetime, Some response_date ->
126 let response_age =
127 match age t with
128 | Some a -> a
129 | None ->
130 (* Calculate age from Date header *)
131 let diff = Ptime.diff now response_date in
132 Ptime.Span.to_int_s diff |> Option.value ~default:0
133 in
134 response_age > lifetime
135 | _ -> false (* Cannot determine staleness without freshness info *)
136
137(** Check if this is a 304 Not Modified response *)
138let is_not_modified t = t.status = 304
139
140(** Get the Vary header which indicates which request headers affect caching *)
141let vary t = Headers.find `Vary t.headers
142
143(** Parse Vary header into list of header names *)
144let vary_headers t =
145 match vary t with
146 | None -> []
147 | Some v ->
148 String.split_on_char ',' v |> List.map String.trim
149 |> List.filter (fun s -> s <> "")
150
151let url t = t.url
152let elapsed t = t.elapsed
153
154let body t =
155 if t.closed then invalid_arg "Response.body: response has been closed"
156 else t.body
157
158let text t =
159 if t.closed then invalid_arg "Response.text: response has been closed"
160 else Eio.Buf_read.of_flow t.body ~max_size:max_int |> Eio.Buf_read.take_all
161
162let json t =
163 let body_str = text t in
164 match Jsont_bytesrw.decode_string' Jsont.json body_str with
165 | Ok json -> json
166 | Error e ->
167 let preview =
168 if String.length body_str > 200 then String.sub body_str 0 200
169 else body_str
170 in
171 raise
172 (Error.err
173 (Error.Json_parse_error
174 { body_preview = preview; reason = Jsont.Error.to_string e }))
175
176let jsonv (type a) (codec : a Jsont.t) t =
177 let body_str = text t in
178 match Jsont_bytesrw.decode_string' codec body_str with
179 | Ok value -> value
180 | Error e ->
181 let preview =
182 if String.length body_str > 200 then String.sub body_str 0 200
183 else body_str
184 in
185 raise
186 (Error.err
187 (Error.Json_parse_error
188 { body_preview = preview; reason = Jsont.Error.to_string e }))
189
190let raise_for_status t =
191 if t.status >= 400 then
192 raise
193 (Error.err
194 (Error.Http_error
195 {
196 url = t.url;
197 status = t.status;
198 reason = Status.reason_phrase (Status.of_int t.status);
199 body_preview = None;
200 headers = Headers.to_list t.headers;
201 (* Convert to list for error type *)
202 }))
203 else t
204
205(** Result-based status check - per Recommendation #21. Returns Ok response for
206 2xx success, Error for 4xx/5xx errors. Enables functional error handling
207 without exceptions. *)
208let check_status t =
209 if t.status >= 400 then
210 Error
211 (Error.Http_error
212 {
213 url = t.url;
214 status = t.status;
215 reason = Status.reason_phrase (Status.of_int t.status);
216 body_preview = None;
217 headers = Headers.to_list t.headers;
218 })
219 else Ok t
220
221(* Pretty printers *)
222let pp ppf t =
223 Fmt.pf ppf
224 "@[<v>Response:@,status: %a@,url: %s@,elapsed: %.3fs@,headers: @[%a@]@]"
225 Status.pp (Status.of_int t.status) t.url t.elapsed Headers.pp_brief
226 t.headers
227
228let pp_detailed ppf t =
229 Fmt.pf ppf "@[<v>Response:@,status: %a@,url: %s@,elapsed: %.3fs@,@[%a@]@]"
230 Status.pp_hum (Status.of_int t.status) t.url t.elapsed Headers.pp t.headers
231
232(* Private module *)
233module Private = struct
234 let make = v
235end