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"
15module Log = (val Logs.src_log src : Logs.LOG)
16
17(** {1 Response Cache-Control Directives}
18
19 RFC 9111 Section 5.2.2: Cache-Control Response Directives *)
20
21type response_directive =
22 | Max_age of int (** max-age=N - response is fresh for N seconds *)
23 | S_maxage of int (** s-maxage=N - shared cache max-age *)
24 | No_cache of string list (** no-cache[=headers] - must revalidate *)
25 | No_store (** no-store - must not be stored *)
26 | No_transform (** no-transform - must not be transformed *)
27 | Must_revalidate (** must-revalidate - stale must be revalidated *)
28 | Proxy_revalidate (** proxy-revalidate - shared caches must revalidate *)
29 | Must_understand (** must-understand - RFC 9111 *)
30 | Private of string list (** private[=headers] - only private cache *)
31 | Public (** public - can be stored by any cache *)
32 | Immutable (** immutable - will not change during freshness *)
33 | Stale_while_revalidate of int (** stale-while-revalidate=N *)
34 | Stale_if_error of int (** stale-if-error=N *)
35 | Response_extension of string * string option (** Unknown directive *)
36
37(** {1 Request Cache-Control Directives}
38
39 RFC 9111 Section 5.2.1: Cache-Control Request Directives *)
40
41type request_directive =
42 | Req_max_age of int (** max-age=N *)
43 | Req_max_stale of int option (** max-stale[=N] *)
44 | Req_min_fresh of int (** min-fresh=N *)
45 | Req_no_cache (** no-cache *)
46 | Req_no_store (** no-store *)
47 | Req_no_transform (** no-transform *)
48 | Req_only_if_cached (** only-if-cached *)
49 | Request_extension of string * string option (** Unknown directive *)
50
51(** Parsed response Cache-Control header *)
52type response = {
53 max_age : int option;
54 s_maxage : int option;
55 no_cache : string list option; (** None = not present, Some [] = present without headers *)
56 no_store : bool;
57 no_transform : bool;
58 must_revalidate : bool;
59 proxy_revalidate : bool;
60 must_understand : bool;
61 private_ : string list option; (** None = not present, Some [] = present without headers *)
62 public : bool;
63 immutable : bool;
64 stale_while_revalidate : int option;
65 stale_if_error : int option;
66 extensions : (string * string option) list;
67}
68
69(** Parsed request Cache-Control header *)
70type request = {
71 req_max_age : int option;
72 req_max_stale : int option option; (** None = not present, Some None = present without value *)
73 req_min_fresh : int option;
74 req_no_cache : bool;
75 req_no_store : bool;
76 req_no_transform : bool;
77 req_only_if_cached : bool;
78 req_extensions : (string * string option) list;
79}
80
81(** {1 Parsing Functions} *)
82
83let empty_response = {
84 max_age = None;
85 s_maxage = None;
86 no_cache = None;
87 no_store = false;
88 no_transform = false;
89 must_revalidate = false;
90 proxy_revalidate = false;
91 must_understand = false;
92 private_ = None;
93 public = false;
94 immutable = false;
95 stale_while_revalidate = None;
96 stale_if_error = None;
97 extensions = [];
98}
99
100let empty_request = {
101 req_max_age = None;
102 req_max_stale = None;
103 req_min_fresh = None;
104 req_no_cache = false;
105 req_no_store = false;
106 req_no_transform = false;
107 req_only_if_cached = false;
108 req_extensions = [];
109}
110
111(** Parse a single token (alphanumeric + some punctuation) *)
112let parse_token s start =
113 let len = String.length s in
114 let rec find_end i =
115 if i >= len then i
116 else match s.[i] with
117 | 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' | '_' | '.' | '!' | '#' | '$'
118 | '%' | '&' | '\'' | '*' | '+' | '^' | '`' | '|' | '~' -> find_end (i + 1)
119 | _ -> i
120 in
121 let end_pos = find_end start in
122 if end_pos = start then None
123 else Some (String.sub s start (end_pos - start), end_pos)
124
125(** Parse a quoted string starting at position (after opening quote) *)
126let parse_quoted_string s start =
127 let buf = Buffer.create 32 in
128 let len = String.length s in
129 let rec loop i =
130 if i >= len then None (* Unterminated quote *)
131 else match s.[i] with
132 | '"' -> Some (Buffer.contents buf, i + 1)
133 | '\\' when i + 1 < len ->
134 Buffer.add_char buf s.[i + 1];
135 loop (i + 2)
136 | c ->
137 Buffer.add_char buf c;
138 loop (i + 1)
139 in
140 loop start
141
142(** Parse a directive value (token or quoted-string) *)
143let parse_value s start =
144 let len = String.length s in
145 if start >= len then None
146 else if s.[start] = '"' then
147 parse_quoted_string s (start + 1)
148 else
149 parse_token s start
150
151(** Parse comma-separated header list (for no-cache=, private=) *)
152let parse_header_list s =
153 (* Handle quoted list like "Accept, Accept-Encoding" *)
154 let s = String.trim s in
155 let s = if String.length s >= 2 && s.[0] = '"' && s.[String.length s - 1] = '"'
156 then String.sub s 1 (String.length s - 2)
157 else s
158 in
159 String.split_on_char ',' s
160 |> List.map String.trim
161 |> List.filter (fun s -> s <> "")
162
163(** Skip whitespace and optional comma *)
164let skip_ws_comma s start =
165 let len = String.length s in
166 let rec loop i =
167 if i >= len then i
168 else match s.[i] with
169 | ' ' | '\t' | ',' -> loop (i + 1)
170 | _ -> i
171 in
172 loop start
173
174(** Parse all directives from a Cache-Control header value *)
175let parse_directives s =
176 let s = String.trim s in
177 let len = String.length s in
178 let rec loop i acc =
179 if i >= len then List.rev acc
180 else
181 let i = skip_ws_comma s i in
182 if i >= len then List.rev acc
183 else match parse_token s i with
184 | None -> List.rev acc (* Invalid, stop parsing *)
185 | Some (name, next_pos) ->
186 let name_lower = String.lowercase_ascii name in
187 (* Check for =value *)
188 let next_pos = skip_ws_comma s next_pos in
189 if next_pos < len && s.[next_pos] = '=' then
190 let value_start = skip_ws_comma s (next_pos + 1) in
191 match parse_value s value_start with
192 | Some (value, end_pos) ->
193 loop (skip_ws_comma s end_pos) ((name_lower, Some value) :: acc)
194 | None ->
195 loop (skip_ws_comma s (next_pos + 1)) ((name_lower, None) :: acc)
196 else
197 loop next_pos ((name_lower, None) :: acc)
198 in
199 loop 0 []
200
201(** Parse response Cache-Control header *)
202let parse_response header_value =
203 let directives = parse_directives header_value in
204 Log.debug (fun m -> m "Parsing response Cache-Control: %s" header_value);
205 List.fold_left (fun acc (name, value) ->
206 match name, value with
207 | "max-age", Some v ->
208 (try { acc with max_age = Some (int_of_string v) }
209 with _ -> acc)
210 | "s-maxage", Some v ->
211 (try { acc with s_maxage = Some (int_of_string v) }
212 with _ -> acc)
213 | "no-cache", None ->
214 { acc with no_cache = Some [] }
215 | "no-cache", Some v ->
216 { acc with no_cache = Some (parse_header_list v) }
217 | "no-store", _ ->
218 { acc with no_store = true }
219 | "no-transform", _ ->
220 { acc with no_transform = true }
221 | "must-revalidate", _ ->
222 { acc with must_revalidate = true }
223 | "proxy-revalidate", _ ->
224 { acc with proxy_revalidate = true }
225 | "must-understand", _ ->
226 { acc with must_understand = true }
227 | "private", None ->
228 { acc with private_ = Some [] }
229 | "private", Some v ->
230 { acc with private_ = Some (parse_header_list v) }
231 | "public", _ ->
232 { acc with public = true }
233 | "immutable", _ ->
234 { acc with immutable = true }
235 | "stale-while-revalidate", Some v ->
236 (try { acc with stale_while_revalidate = Some (int_of_string v) }
237 with _ -> acc)
238 | "stale-if-error", Some v ->
239 (try { acc with stale_if_error = Some (int_of_string v) }
240 with _ -> acc)
241 | other, v ->
242 { 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 (fun acc (name, value) ->
250 match name, value with
251 | "max-age", Some v ->
252 (try { acc with req_max_age = Some (int_of_string v) }
253 with _ -> acc)
254 | "max-stale", None ->
255 { 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 _ -> { 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 _ -> acc)
262 | "no-cache", _ ->
263 { acc with req_no_cache = true }
264 | "no-store", _ ->
265 { acc with req_no_store = true }
266 | "no-transform", _ ->
267 { acc with req_no_transform = true }
268 | "only-if-cached", _ ->
269 { acc with req_only_if_cached = true }
270 | other, v ->
271 { acc with req_extensions = (other, v) :: acc.req_extensions }
272 ) empty_request directives
273
274(** {1 Freshness Calculation}
275
276 RFC 9111 Section 4.2: Freshness *)
277
278(** Calculate freshness lifetime from response directives and headers.
279 Returns freshness lifetime in seconds, or None if not cacheable. *)
280let freshness_lifetime ~response_cc ?expires ?date () =
281 (* RFC 9111 Section 4.2.1: Priority:
282 1. s-maxage (shared caches only, we skip this)
283 2. max-age
284 3. Expires - Date
285 4. Heuristic (we return None, let caller decide) *)
286 let ( let* ) = Option.bind in
287 match response_cc.max_age with
288 | Some age -> Some age
289 | None ->
290 match expires, date with
291 | Some exp_str, Some date_str ->
292 (* Use Http_date.parse to parse HTTP dates *)
293 let* exp_time = Http_date.parse exp_str in
294 let* date_time = Http_date.parse date_str in
295 let diff = Ptime.diff exp_time date_time in
296 Ptime.Span.to_int_s diff
297 | _ -> None
298
299(** Check if a response is cacheable based on Cache-Control directives *)
300let is_cacheable ~response_cc ~status =
301 (* RFC 9111 Section 3: A response is cacheable if:
302 - no-store is not present
303 - status is cacheable by default OR explicit caching directive present *)
304 if response_cc.no_store then false
305 else
306 (* Default cacheable statuses per RFC 9110 Section 15.1 *)
307 let default_cacheable = List.mem status [200; 203; 204; 206; 300; 301; 308; 404; 405; 410; 414; 501] in
308 default_cacheable || Option.is_some response_cc.max_age || Option.is_some response_cc.s_maxage
309
310(** Check if response requires revalidation before use *)
311let must_revalidate ~response_cc =
312 response_cc.must_revalidate || response_cc.proxy_revalidate ||
313 Option.is_some response_cc.no_cache
314
315(** Check if response can be stored in shared caches *)
316let is_public ~response_cc =
317 response_cc.public && not (Option.is_some response_cc.private_)
318
319(** Check if response can only be stored in private caches *)
320let is_private ~response_cc =
321 Option.is_some response_cc.private_
322
323(** {1 Pretty Printers} *)
324
325let pp_response ppf r =
326 let items = [] in
327 let items = match r.max_age with Some a -> Printf.sprintf "max-age=%d" a :: items | None -> items in
328 let items = match r.s_maxage with Some a -> Printf.sprintf "s-maxage=%d" a :: items | None -> items in
329 let items = match r.no_cache with
330 | Some [] -> "no-cache" :: items
331 | Some hs -> Printf.sprintf "no-cache=\"%s\"" (String.concat ", " hs) :: items
332 | None -> items
333 in
334 let items = if r.no_store then "no-store" :: items else items in
335 let items = if r.no_transform then "no-transform" :: items else items in
336 let items = if r.must_revalidate then "must-revalidate" :: items else items in
337 let items = if r.proxy_revalidate then "proxy-revalidate" :: items else items in
338 let items = if r.must_understand then "must-understand" :: items else items in
339 let items = match r.private_ with
340 | Some [] -> "private" :: items
341 | Some hs -> Printf.sprintf "private=\"%s\"" (String.concat ", " hs) :: items
342 | None -> items
343 in
344 let items = if r.public then "public" :: items else items in
345 let items = if r.immutable then "immutable" :: items else items in
346 let items = match r.stale_while_revalidate with
347 | Some s -> Printf.sprintf "stale-while-revalidate=%d" s :: items | None -> items
348 in
349 let items = match r.stale_if_error with
350 | Some s -> Printf.sprintf "stale-if-error=%d" s :: items | None -> items
351 in
352 Format.fprintf ppf "%s" (String.concat ", " (List.rev items))
353
354let pp_request ppf r =
355 let items = [] in
356 let items = match r.req_max_age with Some a -> Printf.sprintf "max-age=%d" a :: items | None -> items in
357 let items = match r.req_max_stale with
358 | Some None -> "max-stale" :: items
359 | Some (Some s) -> Printf.sprintf "max-stale=%d" s :: items
360 | None -> items
361 in
362 let items = match r.req_min_fresh with Some s -> Printf.sprintf "min-fresh=%d" s :: items | None -> items in
363 let items = if r.req_no_cache then "no-cache" :: items else items in
364 let items = if r.req_no_store then "no-store" :: items else items in
365 let items = if r.req_no_transform then "no-transform" :: items else items in
366 let items = if r.req_only_if_cached then "only-if-cached" :: items else items in
367 Format.fprintf ppf "%s" (String.concat ", " (List.rev items))