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
6(** HTTP Response Caching per RFC 9111
7
8 This module provides an in-memory cache for HTTP responses following RFC
9 9111 (HTTP Caching). *)
10
11let src = Logs.Src.create "requests.cache" ~doc:"HTTP Response Caching"
12
13module Log = (val Logs.src_log src : Logs.LOG)
14
15(** {1 Cache Entry} *)
16
17type entry = {
18 url : string;
19 method_ : Method.t;
20 status : int;
21 headers : Headers.t;
22 body : string;
23 request_time : Ptime.t;
24 response_time : Ptime.t;
25 date_value : Ptime.t option;
26 age_value : int;
27 cache_control : Cache_control.response;
28 etag : string option;
29 last_modified : string option;
30 vary_headers : (string * string) list;
31 freshness_lifetime : int option;
32}
33
34type lookup_status = Fresh | Stale
35
36(** {1 Cache Key} *)
37
38type key = {
39 method_key : Method.t;
40 uri : string;
41 vary_values : (string * string) list;
42}
43
44let key ~method_ ~uri ?request_headers ?vary () =
45 let vary_values =
46 match (vary, request_headers) with
47 | Some vary_names, Some headers ->
48 List.filter_map
49 (fun name ->
50 (* Vary header names come from the wire, use string lookup *)
51 match Headers.string name headers with
52 | Some value -> Some (String.lowercase_ascii name, value)
53 | None -> None)
54 vary_names
55 | _ -> []
56 in
57 { method_key = method_; uri; vary_values }
58
59(** {1 Helper Functions} *)
60
61let parse_vary header =
62 String.split_on_char ',' header
63 |> List.map String.trim
64 |> List.filter (fun s -> s <> "")
65 |> List.map String.lowercase_ascii
66
67let vary_matches ~cached_vary ~request_headers =
68 List.for_all
69 (fun (name, cached_value) ->
70 (* Vary header names are dynamic strings from the wire *)
71 match Headers.string name request_headers with
72 | Some req_value -> req_value = cached_value
73 | None -> cached_value = "")
74 cached_vary
75
76(** Parse Age header value *)
77let parse_age headers =
78 match Headers.find `Age headers with
79 | Some age_str -> ( try int_of_string age_str with Failure _ -> 0)
80 | None -> 0
81
82(** Calculate freshness lifetime for a response *)
83let calculate_freshness ~cache_control ~headers ~response_time =
84 (* First try explicit freshness from Cache-Control or Expires *)
85 match
86 Cache_control.freshness_lifetime ~response_cc:cache_control
87 ?expires:(Headers.find `Expires headers)
88 ?date:(Headers.find `Date headers)
89 ()
90 with
91 | Some lifetime -> Some lifetime
92 | None ->
93 (* Fall back to heuristic freshness *)
94 Cache_control.heuristic_freshness
95 ?last_modified:(Headers.find `Last_modified headers)
96 ~response_time ()
97
98(** {1 In-Memory Cache} *)
99
100module Memory = struct
101 type stats = {
102 mutable hits : int;
103 mutable misses : int;
104 mutable stores : int;
105 }
106
107 type t = {
108 entries : (string, entry list) Hashtbl.t;
109 max_entries : int;
110 mutable total_entries : int;
111 stats : stats;
112 mutex : Eio.Mutex.t;
113 }
114
115 let create ?(max_entries = 10000) () =
116 {
117 entries = Hashtbl.create 1024;
118 max_entries;
119 total_entries = 0;
120 stats = { hits = 0; misses = 0; stores = 0 };
121 mutex = Eio.Mutex.create ();
122 }
123
124 (** Check if a method is cacheable *)
125 let is_cacheable_method = function `GET | `HEAD -> true | _ -> false
126
127 (** Evict oldest entries if over limit *)
128 let evict_if_needed t =
129 if t.total_entries > t.max_entries then begin
130 (* Simple eviction: remove ~10% of entries *)
131 let to_remove = t.max_entries / 10 in
132 let removed = ref 0 in
133 Hashtbl.filter_map_inplace
134 (fun _uri entries ->
135 if !removed >= to_remove then Some entries
136 else begin
137 let len = List.length entries in
138 removed := !removed + len;
139 t.total_entries <- t.total_entries - len;
140 None
141 end)
142 t.entries
143 end
144
145 let store t ~url ~method_ ~status ~headers ~body ~request_time ~response_time
146 ?request_headers () =
147 (* Check if cacheable *)
148 if not (is_cacheable_method method_) then begin
149 Log.debug (fun m ->
150 m "Not caching: method %s is not cacheable" (Method.to_string method_));
151 false
152 end
153 else begin
154 let cache_control =
155 match Headers.find `Cache_control headers with
156 | Some cc -> Cache_control.parse_response cc
157 | None -> Cache_control.empty_response
158 in
159 if not (Cache_control.is_cacheable ~response_cc:cache_control ~status)
160 then begin
161 Log.debug (fun m -> m "Not caching: response is not cacheable");
162 false
163 end
164 else begin
165 let date_value =
166 match Headers.find `Date headers with
167 | Some date_str -> Http_date.parse date_str
168 | None -> None
169 in
170 let age_value = parse_age headers in
171 let etag = Headers.find `Etag headers in
172 let last_modified = Headers.find `Last_modified headers in
173 let vary_headers =
174 match (Headers.find `Vary headers, request_headers) with
175 | Some vary, Some req_hdrs ->
176 let vary_names = parse_vary vary in
177 List.filter_map
178 (fun name ->
179 (* Vary header names are dynamic strings from the wire *)
180 match Headers.string name req_hdrs with
181 | Some value -> Some (name, value)
182 | None -> None)
183 vary_names
184 | _ -> []
185 in
186 let freshness_lifetime =
187 calculate_freshness ~cache_control ~headers ~response_time
188 in
189 let entry =
190 {
191 url;
192 method_;
193 status;
194 headers;
195 body;
196 request_time;
197 response_time;
198 date_value;
199 age_value;
200 cache_control;
201 etag;
202 last_modified;
203 vary_headers;
204 freshness_lifetime;
205 }
206 in
207 Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
208 (* Remove any existing entries that match *)
209 let existing =
210 Hashtbl.find_opt t.entries url |> Option.value ~default:[]
211 in
212 let filtered =
213 List.filter
214 (fun e ->
215 e.method_ <> method_
216 || not
217 (vary_matches ~cached_vary:e.vary_headers
218 ~request_headers:
219 (Option.value ~default:Headers.empty request_headers)))
220 existing
221 in
222 Hashtbl.replace t.entries url (entry :: filtered);
223 t.total_entries <- t.total_entries + 1;
224 t.stats.stores <- t.stats.stores + 1;
225 evict_if_needed t);
226 Log.debug (fun m ->
227 m "Cached response for %s (freshness: %s)" url
228 (match freshness_lifetime with
229 | Some s -> Fmt.str "%ds" s
230 | None -> "unknown"));
231 true
232 end
233 end
234
235 let lookup t ~method_ ~uri ?request_headers ~now () =
236 Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
237 match Hashtbl.find_opt t.entries uri with
238 | None ->
239 t.stats.misses <- t.stats.misses + 1;
240 None
241 | Some entries -> (
242 (* Find matching entry *)
243 let request_headers =
244 Option.value ~default:Headers.empty request_headers
245 in
246 let matching =
247 List.find_opt
248 (fun e ->
249 e.method_ = method_
250 && vary_matches ~cached_vary:e.vary_headers ~request_headers)
251 entries
252 in
253 match matching with
254 | None ->
255 t.stats.misses <- t.stats.misses + 1;
256 None
257 | Some entry ->
258 t.stats.hits <- t.stats.hits + 1;
259 (* Calculate current age and freshness *)
260 let inputs : Cache_control.age_inputs =
261 {
262 date_value = entry.date_value;
263 age_value = entry.age_value;
264 request_time = entry.request_time;
265 response_time = entry.response_time;
266 }
267 in
268 let current_age = Cache_control.calculate_age ~inputs ~now in
269 let status =
270 match entry.freshness_lifetime with
271 | Some lifetime
272 when Cache_control.is_fresh ~current_age
273 ~freshness_lifetime:lifetime ->
274 Fresh
275 | _ -> Stale
276 in
277 Log.debug (fun m ->
278 m "Cache %s for %s (age: %ds)"
279 (match status with Fresh -> "hit" | Stale -> "stale")
280 uri current_age);
281 Some (entry, status)))
282
283 let invalidate t ~uri =
284 Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
285 match Hashtbl.find_opt t.entries uri with
286 | Some entries ->
287 t.total_entries <- t.total_entries - List.length entries;
288 Hashtbl.remove t.entries uri;
289 Log.debug (fun m -> m "Invalidated cache for %s" uri)
290 | None -> ())
291
292 let clear t =
293 Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
294 Hashtbl.clear t.entries;
295 t.total_entries <- 0;
296 Log.debug (fun m -> m "Cleared cache"))
297
298 let size t =
299 Eio.Mutex.use_rw ~protect:true t.mutex (fun () -> t.total_entries)
300
301 let stats t =
302 Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
303 (t.stats.hits, t.stats.misses, t.stats.stores))
304end
305
306(** {1 Cache Validation} *)
307
308let needs_validation entry =
309 Cache_control.must_revalidate ~response_cc:entry.cache_control
310
311let validation_headers entry =
312 let headers = Headers.empty in
313 let headers =
314 match entry.etag with
315 | Some etag -> Headers.if_none_match etag headers
316 | None -> headers
317 in
318 let headers =
319 match entry.last_modified with
320 | Some lm -> Headers.if_modified_since lm headers
321 | None -> headers
322 in
323 headers
324
325let is_not_modified ~status = status = 304