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 Cache-Control header parsing per RFC 9111 (HTTP Caching)
7
8 This module provides parsing and representation of Cache-Control directives
9 for both requests and responses. It supports all standard directives from
10 RFC 9111 Section 5.2.
11
12 Per Recommendation #17: Response Caching with RFC 7234/9111 Compliance *)
13
14let src = Logs.Src.create "requests.cache_control" ~doc:"HTTP Cache-Control"
15
16module Log = (val Logs.src_log src : Logs.LOG)
17
18(** {1 Response Cache-Control Directives}
19
20 RFC 9111 Section 5.2.2: Cache-Control Response Directives *)
21
22type response_directive =
23 | Max_age of int (** max-age=N - response is fresh for N seconds *)
24 | S_maxage of int (** s-maxage=N - shared cache max-age *)
25 | No_cache of string list (** no-cache[=headers] - must revalidate *)
26 | No_store (** no-store - must not be stored *)
27 | No_transform (** no-transform - must not be transformed *)
28 | Must_revalidate (** must-revalidate - stale must be revalidated *)
29 | Proxy_revalidate (** proxy-revalidate - shared caches must revalidate *)
30 | Must_understand (** must-understand - RFC 9111 *)
31 | Private of string list (** private[=headers] - only private cache *)
32 | Public (** public - can be stored by any cache *)
33 | Immutable (** immutable - will not change during freshness *)
34 | Stale_while_revalidate of int (** stale-while-revalidate=N *)
35 | Stale_if_error of int (** stale-if-error=N *)
36 | Response_extension of string * string option (** Unknown directive *)
37
38(** {1 Request Cache-Control Directives}
39
40 RFC 9111 Section 5.2.1: Cache-Control Request Directives *)
41
42type request_directive =
43 | Req_max_age of int (** max-age=N *)
44 | Req_max_stale of int option (** max-stale[=N] *)
45 | Req_min_fresh of int (** min-fresh=N *)
46 | Req_no_cache (** no-cache *)
47 | Req_no_store (** no-store *)
48 | Req_no_transform (** no-transform *)
49 | Req_only_if_cached (** only-if-cached *)
50 | Request_extension of string * string option (** Unknown directive *)
51
52type response = {
53 max_age : int option;
54 s_maxage : int option;
55 no_cache : string list option;
56 (** None = not present, Some [] = present without headers *)
57 no_store : bool;
58 no_transform : bool;
59 must_revalidate : bool;
60 proxy_revalidate : bool;
61 must_understand : bool;
62 private_ : string list option;
63 (** None = not present, Some [] = present without headers *)
64 public : bool;
65 immutable : bool;
66 stale_while_revalidate : int option;
67 stale_if_error : int option;
68 extensions : (string * string option) list;
69}
70(** Parsed response Cache-Control header *)
71
72type request = {
73 req_max_age : int option;
74 req_max_stale : int option option;
75 (** None = not present, Some None = present without value *)
76 req_min_fresh : int option;
77 req_no_cache : bool;
78 req_no_store : bool;
79 req_no_transform : bool;
80 req_only_if_cached : bool;
81 req_extensions : (string * string option) list;
82}
83(** Parsed request Cache-Control header *)
84
85(** {1 Parsing Functions} *)
86
87let empty_response =
88 {
89 max_age = None;
90 s_maxage = None;
91 no_cache = None;
92 no_store = false;
93 no_transform = false;
94 must_revalidate = false;
95 proxy_revalidate = false;
96 must_understand = false;
97 private_ = None;
98 public = false;
99 immutable = false;
100 stale_while_revalidate = None;
101 stale_if_error = None;
102 extensions = [];
103 }
104
105let empty_request =
106 {
107 req_max_age = None;
108 req_max_stale = None;
109 req_min_fresh = None;
110 req_no_cache = false;
111 req_no_store = false;
112 req_no_transform = false;
113 req_only_if_cached = false;
114 req_extensions = [];
115 }
116
117(** Parse a single token (alphanumeric + some punctuation) *)
118let parse_token s start =
119 let len = String.length s in
120 let rec find_end i =
121 if i >= len then i
122 else
123 match s.[i] with
124 | 'a' .. 'z'
125 | 'A' .. 'Z'
126 | '0' .. '9'
127 | '-' | '_' | '.' | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '^'
128 | '`' | '|' | '~' ->
129 find_end (i + 1)
130 | _ -> i
131 in
132 let end_pos = find_end start in
133 if end_pos = start then None
134 else Some (String.sub s start (end_pos - start), end_pos)
135
136(** Parse a quoted string starting at position (after opening quote) *)
137let parse_quoted_string s start =
138 let buf = Buffer.create 32 in
139 let len = String.length s in
140 let rec loop i =
141 if i >= len then None (* Unterminated quote *)
142 else
143 match s.[i] with
144 | '"' -> Some (Buffer.contents buf, i + 1)
145 | '\\' when i + 1 < len ->
146 Buffer.add_char buf s.[i + 1];
147 loop (i + 2)
148 | c ->
149 Buffer.add_char buf c;
150 loop (i + 1)
151 in
152 loop start
153
154(** Parse a directive value (token or quoted-string) *)
155let parse_value s start =
156 let len = String.length s in
157 if start >= len then None
158 else if s.[start] = '"' then parse_quoted_string s (start + 1)
159 else parse_token s start
160
161(** Parse comma-separated header list (for no-cache=, private=) *)
162let parse_header_list s =
163 (* Handle quoted list like "Accept, Accept-Encoding" *)
164 let s = String.trim s in
165 let s =
166 if String.length s >= 2 && s.[0] = '"' && s.[String.length s - 1] = '"' then
167 String.sub s 1 (String.length s - 2)
168 else s
169 in
170 String.split_on_char ',' s |> List.map String.trim
171 |> List.filter (fun s -> s <> "")
172
173(** Skip whitespace and optional comma *)
174let skip_ws_comma s start =
175 let len = String.length s in
176 let rec loop i =
177 if i >= len then i
178 else match s.[i] with ' ' | '\t' | ',' -> loop (i + 1) | _ -> i
179 in
180 loop start
181
182(** Parse all directives from a Cache-Control header value *)
183let parse_directives s =
184 let s = String.trim s in
185 let len = String.length s in
186 let rec loop i acc =
187 if i >= len then List.rev acc
188 else
189 let i = skip_ws_comma s i in
190 if i >= len then List.rev acc
191 else
192 match parse_token s i with
193 | None -> List.rev acc (* Invalid, stop parsing *)
194 | Some (name, next_pos) ->
195 let name_lower = String.lowercase_ascii name in
196 (* Check for =value *)
197 let next_pos = skip_ws_comma s next_pos in
198 if next_pos < len && s.[next_pos] = '=' then
199 let value_start = skip_ws_comma s (next_pos + 1) in
200 match parse_value s value_start with
201 | Some (value, end_pos) ->
202 loop (skip_ws_comma s end_pos)
203 ((name_lower, Some value) :: acc)
204 | None ->
205 loop
206 (skip_ws_comma s (next_pos + 1))
207 ((name_lower, None) :: acc)
208 else loop next_pos ((name_lower, None) :: acc)
209 in
210 loop 0 []
211
212(** Parse response Cache-Control header *)
213let parse_response header_value =
214 let directives = parse_directives header_value in
215 Log.debug (fun m -> m "Parsing response Cache-Control: %s" header_value);
216 List.fold_left
217 (fun acc (name, value) ->
218 match (name, value) with
219 | "max-age", Some v -> (
220 try { acc with max_age = Some (int_of_string v) }
221 with Failure _ -> acc)
222 | "s-maxage", Some v -> (
223 try { acc with s_maxage = Some (int_of_string v) }
224 with Failure _ -> acc)
225 | "no-cache", None -> { acc with no_cache = Some [] }
226 | "no-cache", Some v -> { acc with no_cache = Some (parse_header_list v) }
227 | "no-store", _ -> { acc with no_store = true }
228 | "no-transform", _ -> { acc with no_transform = true }
229 | "must-revalidate", _ -> { acc with must_revalidate = true }
230 | "proxy-revalidate", _ -> { acc with proxy_revalidate = true }
231 | "must-understand", _ -> { acc with must_understand = true }
232 | "private", None -> { acc with private_ = Some [] }
233 | "private", Some v -> { acc with private_ = Some (parse_header_list v) }
234 | "public", _ -> { acc with public = true }
235 | "immutable", _ -> { acc with immutable = true }
236 | "stale-while-revalidate", Some v -> (
237 try { acc with stale_while_revalidate = Some (int_of_string v) }
238 with Failure _ -> acc)
239 | "stale-if-error", Some v -> (
240 try { acc with stale_if_error = Some (int_of_string v) }
241 with Failure _ -> acc)
242 | other, v -> { acc with extensions = (other, v) :: acc.extensions })
243 empty_response directives
244
245(** Parse request Cache-Control header *)
246let parse_request header_value =
247 let directives = parse_directives header_value in
248 Log.debug (fun m -> m "Parsing request Cache-Control: %s" header_value);
249 List.fold_left
250 (fun acc (name, value) ->
251 match (name, value) with
252 | "max-age", Some v -> (
253 try { acc with req_max_age = Some (int_of_string v) }
254 with Failure _ -> acc)
255 | "max-stale", None -> { acc with req_max_stale = Some None }
256 | "max-stale", Some v -> (
257 try { acc with req_max_stale = Some (Some (int_of_string v)) }
258 with Failure _ -> { acc with req_max_stale = Some None })
259 | "min-fresh", Some v -> (
260 try { acc with req_min_fresh = Some (int_of_string v) }
261 with Failure _ -> acc)
262 | "no-cache", _ -> { acc with req_no_cache = true }
263 | "no-store", _ -> { acc with req_no_store = true }
264 | "no-transform", _ -> { acc with req_no_transform = true }
265 | "only-if-cached", _ -> { acc with req_only_if_cached = true }
266 | other, v ->
267 { acc with req_extensions = (other, v) :: acc.req_extensions })
268 empty_request directives
269
270(** {1 Freshness Calculation}
271
272 RFC 9111 Section 4.2: Freshness *)
273
274(** Calculate freshness lifetime from response directives and headers. Returns
275 freshness lifetime in seconds, or None if not cacheable. *)
276let freshness_lifetime ~response_cc ?expires ?date () =
277 (* RFC 9111 Section 4.2.1: Priority:
278 1. s-maxage (shared caches only, we skip this)
279 2. max-age
280 3. Expires - Date
281 4. Heuristic (we return None, let caller decide) *)
282 let ( let* ) = Option.bind in
283 match response_cc.max_age with
284 | Some age -> Some age
285 | None -> (
286 match (expires, date) with
287 | Some exp_str, Some date_str ->
288 (* Use Http_date.parse to parse HTTP dates *)
289 let* exp_time = Http_date.parse exp_str in
290 let* date_time = Http_date.parse date_str in
291 let diff = Ptime.diff exp_time date_time in
292 Ptime.Span.to_int_s diff
293 | _ -> None)
294
295(** {1 Age Calculation}
296
297 RFC 9111 Section 4.2.3: Calculating Age *)
298
299type age_inputs = {
300 date_value : Ptime.t option;
301 (** Value of Date header (when response was generated) *)
302 age_value : int; (** Value of Age header in seconds (0 if not present) *)
303 request_time : Ptime.t; (** Time when the request was initiated *)
304 response_time : Ptime.t; (** Time when the response was received *)
305}
306(** Age calculation inputs *)
307
308(** Calculate the current age of a cached response. Per RFC 9111 Section 4.2.3:
309
310 {v
311 apparent_age = max(0, response_time - date_value)
312 response_delay = response_time - request_time
313 corrected_age_value = age_value + response_delay
314 corrected_initial_age = max(apparent_age, corrected_age_value)
315 resident_time = now - response_time
316 current_age = corrected_initial_age + resident_time
317 v}
318
319 @param inputs Age calculation inputs
320 @param now Current time
321 @return Current age in seconds *)
322let calculate_age ~inputs ~now =
323 (* apparent_age = max(0, response_time - date_value) *)
324 let apparent_age =
325 match inputs.date_value with
326 | Some date ->
327 let diff = Ptime.diff inputs.response_time date in
328 max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
329 | None -> 0
330 in
331 (* response_delay = response_time - request_time *)
332 let response_delay =
333 let diff = Ptime.diff inputs.response_time inputs.request_time in
334 max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
335 in
336 (* corrected_age_value = age_value + response_delay *)
337 let corrected_age_value = inputs.age_value + response_delay in
338 (* corrected_initial_age = max(apparent_age, corrected_age_value) *)
339 let corrected_initial_age = max apparent_age corrected_age_value in
340 (* resident_time = now - response_time *)
341 let resident_time =
342 let diff = Ptime.diff now inputs.response_time in
343 max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
344 in
345 (* current_age = corrected_initial_age + resident_time *)
346 corrected_initial_age + resident_time
347
348(** {1 Heuristic Freshness}
349
350 RFC 9111 Section 4.2.2: Calculating Heuristic Freshness *)
351
352(** Default heuristic fraction: 10% of time since Last-Modified. RFC 9111
353 recommends this as a typical value. *)
354let default_heuristic_fraction = 0.10
355
356(** Maximum heuristic freshness lifetime: 1 day (86400 seconds). This prevents
357 excessively long heuristic caching. *)
358let default_max_heuristic_age = 86400
359
360(** Calculate heuristic freshness lifetime when no explicit caching info
361 provided. Per RFC 9111 Section 4.2.2, caches MAY use heuristics when
362 explicit freshness is not available.
363
364 @param last_modified Value of Last-Modified header
365 @param response_time When the response was received
366 @param fraction Fraction of (now - last_modified) to use (default 10%)
367 @param max_age Maximum heuristic age in seconds (default 1 day)
368 @return Heuristic freshness lifetime in seconds, or None *)
369let heuristic_freshness ?last_modified ~response_time
370 ?(fraction = default_heuristic_fraction)
371 ?(max_age = default_max_heuristic_age) () =
372 match last_modified with
373 | Some lm_str -> (
374 match Http_date.parse lm_str with
375 | Some lm_time ->
376 let age_since_modified =
377 let diff = Ptime.diff response_time lm_time in
378 max 0 (Option.value ~default:0 (Ptime.Span.to_int_s diff))
379 in
380 let heuristic =
381 int_of_float (float_of_int age_since_modified *. fraction)
382 in
383 Some (min heuristic max_age)
384 | None ->
385 Log.debug (fun m -> m "Failed to parse Last-Modified: %s" lm_str);
386 None)
387 | None -> None
388
389(** Check if a cached response is fresh.
390
391 @param current_age Current age from calculate_age
392 @param freshness_lifetime From freshness_lifetime or heuristic_freshness
393 @return true if the response is still fresh *)
394let is_fresh ~current_age ~freshness_lifetime = current_age < freshness_lifetime
395
396(** Check if a stale response can still be served based on request directives.
397
398 @param request_cc Parsed request Cache-Control
399 @param current_age Current age of the cached response
400 @param freshness_lifetime Freshness lifetime of the cached response
401 @return true if the stale response can be served *)
402let can_serve_stale ~request_cc ~current_age ~freshness_lifetime =
403 let staleness = current_age - freshness_lifetime in
404 if staleness <= 0 then true (* Not stale *)
405 else
406 match request_cc.req_max_stale with
407 | Some None -> true (* max-stale without value: accept any staleness *)
408 | Some (Some allowed_stale) -> staleness <= allowed_stale
409 | None -> false (* No max-stale: don't serve stale *)
410
411(** Check if a response is cacheable based on Cache-Control directives *)
412let is_cacheable ~response_cc ~status =
413 (* RFC 9111 Section 3: A response is cacheable if:
414 - no-store is not present
415 - status is cacheable by default OR explicit caching directive present *)
416 if response_cc.no_store then false
417 else
418 (* Default cacheable statuses per RFC 9110 Section 15.1 *)
419 let default_cacheable =
420 List.mem status
421 [ 200; 203; 204; 206; 300; 301; 308; 404; 405; 410; 414; 501 ]
422 in
423 default_cacheable
424 || Option.is_some response_cc.max_age
425 || Option.is_some response_cc.s_maxage
426
427(** Check if response requires revalidation before use *)
428let must_revalidate ~response_cc =
429 response_cc.must_revalidate || response_cc.proxy_revalidate
430 || Option.is_some response_cc.no_cache
431
432(** Check if response can be stored in shared caches *)
433let is_public ~response_cc =
434 response_cc.public && not (Option.is_some response_cc.private_)
435
436(** Check if response can only be stored in private caches *)
437let is_private ~response_cc = Option.is_some response_cc.private_
438
439(** {1 Pretty Printers} *)
440
441let add_opt_int key v acc =
442 match v with Some n -> Fmt.str "%s=%d" key n :: acc | None -> acc
443
444let add_flag key b acc = if b then key :: acc else acc
445
446let add_opt_field key v acc =
447 match v with
448 | Some [] -> key :: acc
449 | Some hs -> Fmt.str "%s=\"%s\"" key (String.concat ", " hs) :: acc
450 | None -> acc
451
452let pp_response ppf r =
453 let items =
454 []
455 |> add_opt_int "max-age" r.max_age
456 |> add_opt_int "s-maxage" r.s_maxage
457 |> add_opt_field "no-cache" r.no_cache
458 |> add_flag "no-store" r.no_store
459 |> add_flag "no-transform" r.no_transform
460 |> add_flag "must-revalidate" r.must_revalidate
461 |> add_flag "proxy-revalidate" r.proxy_revalidate
462 |> add_flag "must-understand" r.must_understand
463 |> add_opt_field "private" r.private_
464 |> add_flag "public" r.public
465 |> add_flag "immutable" r.immutable
466 |> add_opt_int "stale-while-revalidate" r.stale_while_revalidate
467 |> add_opt_int "stale-if-error" r.stale_if_error
468 in
469 Fmt.pf ppf "%s" (String.concat ", " (List.rev items))
470
471let pp_request ppf r =
472 let items = [] in
473 let items =
474 match r.req_max_age with
475 | Some a -> Fmt.str "max-age=%d" a :: items
476 | None -> items
477 in
478 let items =
479 match r.req_max_stale with
480 | Some None -> "max-stale" :: items
481 | Some (Some s) -> Fmt.str "max-stale=%d" s :: items
482 | None -> items
483 in
484 let items =
485 match r.req_min_fresh with
486 | Some s -> Fmt.str "min-fresh=%d" s :: items
487 | None -> items
488 in
489 let items = if r.req_no_cache then "no-cache" :: items else items in
490 let items = if r.req_no_store then "no-store" :: items else items in
491 let items = if r.req_no_transform then "no-transform" :: items else items in
492 let items =
493 if r.req_only_if_cached then "only-if-cached" :: items else items
494 in
495 Fmt.pf ppf "%s" (String.concat ", " (List.rev items))