Add Cache-Status, Content-Digest, and HSTS header parsing · anil.recoil.org/ocaml-requests@c393d23

+350

lib/header_parsing.ml

··· 343 343 let supports_byte_ranges = function 344 344 | Accept_ranges_bytes -> true 345 345 | Accept_ranges_none | Accept_ranges_other _ -> false 346 + 347 + (** {1 Cache-Status (RFC 9211)} 348 + 349 + The Cache-Status header field indicates how caches have handled a request. 350 + It is a List structured field (RFC 8941) where each member is a cache 351 + identifier with optional parameters. 352 + 353 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: The Cache-Status HTTP Response Header Field *) 354 + 355 + (** Forward/stored response indicator for Cache-Status *) 356 + type cache_status_fwd = 357 + | Fwd_uri_miss 358 + (** The cache did not contain any matching response *) 359 + | Fwd_vary_miss 360 + (** The cache contained a response, but Vary header prevented match *) 361 + | Fwd_miss 362 + (** The cache did not find a usable response (generic) *) 363 + | Fwd_request 364 + (** The request semantics required forwarding (e.g., no-cache) *) 365 + | Fwd_stale 366 + (** The cache had a stale response that needed revalidation *) 367 + | Fwd_partial 368 + (** The cache had a partial response that needed completion *) 369 + | Fwd_bypass 370 + (** The cache was configured to bypass for this request *) 371 + | Fwd_other of string 372 + (** Other forward reason *) 373 + 374 + (** A single cache status entry from the Cache-Status header *) 375 + type cache_status_entry = { 376 + cache_id : string; 377 + (** Identifier for the cache (e.g., "CDN", "proxy", "Cloudflare") *) 378 + hit : bool option; 379 + (** True if served from cache without forwarding *) 380 + fwd : cache_status_fwd option; 381 + (** Why the request was forwarded *) 382 + fwd_status : int option; 383 + (** Status code from the forwarded response *) 384 + stored : bool option; 385 + (** Whether the response was stored in cache *) 386 + collapsed : bool option; 387 + (** Whether request was collapsed with others *) 388 + ttl : int option; 389 + (** Time-to-live remaining in seconds *) 390 + key : string option; 391 + (** Cache key used *) 392 + detail : string option; 393 + (** Implementation-specific detail *) 394 + } 395 + 396 + let cache_status_fwd_of_string = function 397 + | "uri-miss" -> Fwd_uri_miss 398 + | "vary-miss" -> Fwd_vary_miss 399 + | "miss" -> Fwd_miss 400 + | "request" -> Fwd_request 401 + | "stale" -> Fwd_stale 402 + | "partial" -> Fwd_partial 403 + | "bypass" -> Fwd_bypass 404 + | other -> Fwd_other other 405 + 406 + let cache_status_fwd_to_string = function 407 + | Fwd_uri_miss -> "uri-miss" 408 + | Fwd_vary_miss -> "vary-miss" 409 + | Fwd_miss -> "miss" 410 + | Fwd_request -> "request" 411 + | Fwd_stale -> "stale" 412 + | Fwd_partial -> "partial" 413 + | Fwd_bypass -> "bypass" 414 + | Fwd_other s -> s 415 + 416 + (** Parse a single Cache-Status entry. 417 + Format: cache-id; param1; param2=value; param3="quoted" *) 418 + let parse_cache_status_entry s = 419 + let s = String.trim s in 420 + let parts = String.split_on_char ';' s in 421 + match parts with 422 + | [] -> None 423 + | cache_id_part :: params -> 424 + let cache_id = String.trim cache_id_part in 425 + if cache_id = "" then None 426 + else 427 + let parse_param acc p = 428 + let p = String.trim p in 429 + match String.index_opt p '=' with 430 + | None -> 431 + (* Boolean parameter (presence = true) *) 432 + (String.lowercase_ascii p, "?1") :: acc 433 + | Some eq_idx -> 434 + let key = String.trim (String.sub p 0 eq_idx) in 435 + let value = String.trim (String.sub p (eq_idx + 1) (String.length p - eq_idx - 1)) in 436 + (* Remove quotes if present *) 437 + let value = 438 + if String.length value >= 2 && value.[0] = '"' && value.[String.length value - 1] = '"' then 439 + String.sub value 1 (String.length value - 2) 440 + else value 441 + in 442 + (String.lowercase_ascii key, value) :: acc 443 + in 444 + let param_list = List.fold_left parse_param [] params in 445 + let get_bool key = 446 + match List.assoc_opt key param_list with 447 + | Some "?1" | Some "true" | Some "1" -> Some true 448 + | Some "?0" | Some "false" | Some "0" -> Some false 449 + | _ -> None 450 + in 451 + let get_int key = 452 + match List.assoc_opt key param_list with 453 + | Some v -> int_of_string_opt v 454 + | None -> None 455 + in 456 + let get_string key = List.assoc_opt key param_list in 457 + Some { 458 + cache_id; 459 + hit = get_bool "hit"; 460 + fwd = Option.map cache_status_fwd_of_string (get_string "fwd"); 461 + fwd_status = get_int "fwd-status"; 462 + stored = get_bool "stored"; 463 + collapsed = get_bool "collapsed"; 464 + ttl = get_int "ttl"; 465 + key = get_string "key"; 466 + detail = get_string "detail"; 467 + } 468 + 469 + (** Parse a Cache-Status header value into a list of entries. 470 + Multiple caches are separated by commas, with the response generator first. *) 471 + let parse_cache_status s = 472 + String.split_on_char ',' s 473 + |> List.filter_map parse_cache_status_entry 474 + 475 + (** Format a Cache-Status entry as a string. *) 476 + let cache_status_entry_to_string entry = 477 + let params = [] in 478 + let params = match entry.detail with Some v -> ("detail", Printf.sprintf "\"%s\"" v) :: params | None -> params in 479 + let params = match entry.key with Some v -> ("key", Printf.sprintf "\"%s\"" v) :: params | None -> params in 480 + let params = match entry.ttl with Some v -> ("ttl", string_of_int v) :: params | None -> params in 481 + let params = match entry.collapsed with Some true -> ("collapsed", "") :: params | _ -> params in 482 + let params = match entry.stored with Some true -> ("stored", "") :: params | _ -> params in 483 + let params = match entry.fwd_status with Some v -> ("fwd-status", string_of_int v) :: params | None -> params in 484 + let params = match entry.fwd with Some v -> ("fwd", cache_status_fwd_to_string v) :: params | None -> params in 485 + let params = match entry.hit with Some true -> ("hit", "") :: params | _ -> params in 486 + let param_strs = List.map (fun (k, v) -> 487 + if v = "" then k else k ^ "=" ^ v 488 + ) params in 489 + match param_strs with 490 + | [] -> entry.cache_id 491 + | _ -> entry.cache_id ^ "; " ^ String.concat "; " param_strs 492 + 493 + (** Format a list of Cache-Status entries as a header value. *) 494 + let cache_status_to_string entries = 495 + String.concat ", " (List.map cache_status_entry_to_string entries) 496 + 497 + (** Check if any cache reported a hit. *) 498 + let cache_status_is_hit entries = 499 + List.exists (fun e -> e.hit = Some true) entries 500 + 501 + (** Check if the response was stored by any cache. *) 502 + let cache_status_is_stored entries = 503 + List.exists (fun e -> e.stored = Some true) entries 504 + 505 + (** Get the forward reason from the first cache that forwarded. *) 506 + let cache_status_get_fwd entries = 507 + List.find_map (fun e -> e.fwd) entries 508 + 509 + (** {1 Content-Digest / Repr-Digest (RFC 9530)} 510 + 511 + Content-Digest contains a digest of the content (after content coding). 512 + Repr-Digest contains a digest of the representation (before content coding). 513 + 514 + Format: algorithm=:base64-digest:, algorithm=:base64-digest: 515 + 516 + @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields *) 517 + 518 + (** Supported digest algorithms *) 519 + type digest_algorithm = 520 + | Sha256 521 + (** SHA-256 (recommended) *) 522 + | Sha512 523 + (** SHA-512 *) 524 + | Other of string 525 + (** Other algorithm (for forward compatibility) *) 526 + 527 + let digest_algorithm_of_string s = 528 + match String.lowercase_ascii s with 529 + | "sha-256" -> Sha256 530 + | "sha-512" -> Sha512 531 + | other -> Other other 532 + 533 + let digest_algorithm_to_string = function 534 + | Sha256 -> "sha-256" 535 + | Sha512 -> "sha-512" 536 + | Other s -> s 537 + 538 + (** A single digest value with its algorithm *) 539 + type digest_value = { 540 + algorithm : digest_algorithm; 541 + (** The hash algorithm used *) 542 + digest : string; 543 + (** The base64-encoded digest value *) 544 + } 545 + 546 + (** Parse a Content-Digest or Repr-Digest header value. 547 + Format: sha-256=:base64data:, sha-512=:base64data: *) 548 + let parse_digest_header s = 549 + String.split_on_char ',' s 550 + |> List.filter_map (fun part -> 551 + let part = String.trim part in 552 + match String.index_opt part '=' with 553 + | None -> None 554 + | Some eq_idx -> 555 + let algo = String.trim (String.sub part 0 eq_idx) in 556 + let value = String.trim (String.sub part (eq_idx + 1) (String.length part - eq_idx - 1)) in 557 + (* RFC 9530 uses :base64: format for byte sequences *) 558 + let digest = 559 + if String.length value >= 2 && value.[0] = ':' && value.[String.length value - 1] = ':' then 560 + String.sub value 1 (String.length value - 2) 561 + else value 562 + in 563 + Some { algorithm = digest_algorithm_of_string algo; digest } 564 + ) 565 + 566 + (** Format a digest value as a string. *) 567 + let digest_value_to_string dv = 568 + Printf.sprintf "%s=:%s:" (digest_algorithm_to_string dv.algorithm) dv.digest 569 + 570 + (** Format a list of digest values as a header value. *) 571 + let digest_header_to_string digests = 572 + String.concat ", " (List.map digest_value_to_string digests) 573 + 574 + (** Compute the SHA-256 digest of content and return base64-encoded result. *) 575 + let compute_sha256 content = 576 + let hash = Digestif.SHA256.digest_string content in 577 + Base64.encode_string (Digestif.SHA256.to_raw_string hash) 578 + 579 + (** Compute the SHA-512 digest of content and return base64-encoded result. *) 580 + let compute_sha512 content = 581 + let hash = Digestif.SHA512.digest_string content in 582 + Base64.encode_string (Digestif.SHA512.to_raw_string hash) 583 + 584 + (** Compute a digest for content using the specified algorithm. *) 585 + let compute_digest ~algorithm content = 586 + let digest = match algorithm with 587 + | Sha256 -> compute_sha256 content 588 + | Sha512 -> compute_sha512 content 589 + | Other _ -> 590 + Log.warn (fun m -> m "Unsupported digest algorithm, using SHA-256"); 591 + compute_sha256 content 592 + in 593 + { algorithm; digest } 594 + 595 + (** Create a Content-Digest header value for content. 596 + Defaults to SHA-256 which is recommended by RFC 9530. *) 597 + let make_content_digest ?(algorithm = Sha256) content = 598 + compute_digest ~algorithm content 599 + 600 + (** Validate that a digest matches the content. 601 + Returns true if any of the provided digests matches. *) 602 + let validate_digest ~digests content = 603 + List.exists (fun dv -> 604 + let computed = compute_digest ~algorithm:dv.algorithm content in 605 + computed.digest = dv.digest 606 + ) digests 607 + 608 + (** Get the strongest available digest (prefer SHA-512 over SHA-256). *) 609 + let get_strongest_digest digests = 610 + let sha512 = List.find_opt (fun d -> d.algorithm = Sha512) digests in 611 + let sha256 = List.find_opt (fun d -> d.algorithm = Sha256) digests in 612 + match sha512, sha256 with 613 + | Some d, _ -> Some d 614 + | None, Some d -> Some d 615 + | None, None -> List.nth_opt digests 0 616 + 617 + (** {1 Strict-Transport-Security (RFC 6797)} 618 + 619 + The Strict-Transport-Security (HSTS) header tells browsers to only 620 + access the site over HTTPS. 621 + 622 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *) 623 + 624 + (** HSTS directive values *) 625 + type hsts = { 626 + max_age : int64; 627 + (** Required: Time in seconds the browser should remember HTTPS-only *) 628 + include_subdomains : bool; 629 + (** If true, policy applies to all subdomains *) 630 + preload : bool; 631 + (** If true, site requests inclusion in browser preload lists *) 632 + } 633 + 634 + (** Parse a Strict-Transport-Security header value. 635 + Format: max-age=31536000; includeSubDomains; preload *) 636 + let parse_hsts s = 637 + let directives = 638 + String.split_on_char ';' s 639 + |> List.map String.trim 640 + |> List.filter (fun s -> String.length s > 0) 641 + in 642 + let max_age = ref None in 643 + let include_subdomains = ref false in 644 + let preload = ref false in 645 + List.iter (fun directive -> 646 + let directive_lower = String.lowercase_ascii directive in 647 + if String.length directive_lower >= 8 && 648 + String.sub directive_lower 0 8 = "max-age=" then begin 649 + let value_str = String.sub directive 8 (String.length directive - 8) in 650 + max_age := Int64.of_string_opt (String.trim value_str) 651 + end 652 + else if directive_lower = "includesubdomains" then 653 + include_subdomains := true 654 + else if directive_lower = "preload" then 655 + preload := true 656 + else 657 + Log.debug (fun m -> m "Unknown HSTS directive: %s" directive) 658 + ) directives; 659 + match !max_age with 660 + | Some age -> Some { 661 + max_age = age; 662 + include_subdomains = !include_subdomains; 663 + preload = !preload; 664 + } 665 + | None -> 666 + Log.debug (fun m -> m "HSTS header missing required max-age directive"); 667 + None 668 + 669 + (** Format an HSTS value as a header string. *) 670 + let hsts_to_string hsts = 671 + let parts = [Printf.sprintf "max-age=%Ld" hsts.max_age] in 672 + let parts = if hsts.include_subdomains then parts @ ["includeSubDomains"] else parts in 673 + let parts = if hsts.preload then parts @ ["preload"] else parts in 674 + String.concat "; " parts 675 + 676 + (** Create an HSTS header value. 677 + @param max_age Time in seconds (default: 1 year = 31536000) 678 + @param include_subdomains Apply to subdomains (default: false) 679 + @param preload Request preload list inclusion (default: false) *) 680 + let make_hsts ?(max_age = 31536000L) ?(include_subdomains = false) ?(preload = false) () = 681 + { max_age; include_subdomains; preload } 682 + 683 + (** Check if HSTS is effectively enabled (max-age > 0). *) 684 + let hsts_is_enabled hsts = hsts.max_age > 0L 685 + 686 + (** Common HSTS configurations *) 687 + 688 + (** One year with subdomains - recommended for production *) 689 + let hsts_one_year_subdomains = { max_age = 31536000L; include_subdomains = true; preload = false } 690 + 691 + (** Two years with subdomains and preload - for HSTS preload submission *) 692 + let hsts_preload = { max_age = 63072000L; include_subdomains = true; preload = true } 693 + 694 + (** Disable HSTS by setting max-age to 0 *) 695 + let hsts_disable = { max_age = 0L; include_subdomains = false; preload = false }

+211 -1

lib/header_parsing.mli

··· 16 16 - {!Authentication-Info} - Post-authentication info (RFC 9110 Section 11.6.3) 17 17 - {!Retry-After} - Retry delay specification (RFC 9110 Section 10.2.3) 18 18 - {!Accept-Ranges} - Range support indication (RFC 9110 Section 14.3) 19 + - {!Cache-Status} - Cache handling indication (RFC 9211) 20 + - {!Content-Digest} / {!Repr-Digest} - Body integrity verification (RFC 9530) 21 + - {!Strict-Transport-Security} - HSTS policy (RFC 6797) 19 22 20 - @see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics *) 23 + @see <https://www.rfc-editor.org/rfc/rfc9110> RFC 9110: HTTP Semantics 24 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: Cache-Status 25 + @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields 26 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *) 21 27 22 28 (** {1 Content-Range (RFC 9110 Section 14.4)} 23 29 ··· 202 208 203 209 val supports_byte_ranges : accept_ranges -> bool 204 210 (** [supports_byte_ranges ar] returns [true] if byte range requests are supported. *) 211 + 212 + (** {1 Cache-Status (RFC 9211)} 213 + 214 + The Cache-Status header field indicates how caches have handled a request. 215 + It is a List structured field (RFC 8941) where each member is a cache 216 + identifier with optional parameters. 217 + 218 + Example: [Cache-Status: "Cloudflare"; hit, ExampleCDN; fwd=uri-miss; stored] 219 + 220 + @see <https://www.rfc-editor.org/rfc/rfc9211> RFC 9211: The Cache-Status HTTP Response Header Field *) 221 + 222 + (** Forward/stored response indicator for Cache-Status *) 223 + type cache_status_fwd = 224 + | Fwd_uri_miss 225 + (** The cache did not contain any matching response *) 226 + | Fwd_vary_miss 227 + (** The cache contained a response, but Vary header prevented match *) 228 + | Fwd_miss 229 + (** The cache did not find a usable response (generic) *) 230 + | Fwd_request 231 + (** The request semantics required forwarding (e.g., no-cache) *) 232 + | Fwd_stale 233 + (** The cache had a stale response that needed revalidation *) 234 + | Fwd_partial 235 + (** The cache had a partial response that needed completion *) 236 + | Fwd_bypass 237 + (** The cache was configured to bypass for this request *) 238 + | Fwd_other of string 239 + (** Other forward reason *) 240 + 241 + (** A single cache status entry from the Cache-Status header *) 242 + type cache_status_entry = { 243 + cache_id : string; 244 + (** Identifier for the cache (e.g., "CDN", "proxy", "Cloudflare") *) 245 + hit : bool option; 246 + (** True if served from cache without forwarding *) 247 + fwd : cache_status_fwd option; 248 + (** Why the request was forwarded *) 249 + fwd_status : int option; 250 + (** Status code from the forwarded response *) 251 + stored : bool option; 252 + (** Whether the response was stored in cache *) 253 + collapsed : bool option; 254 + (** Whether request was collapsed with others *) 255 + ttl : int option; 256 + (** Time-to-live remaining in seconds *) 257 + key : string option; 258 + (** Cache key used *) 259 + detail : string option; 260 + (** Implementation-specific detail *) 261 + } 262 + 263 + val cache_status_fwd_of_string : string -> cache_status_fwd 264 + (** [cache_status_fwd_of_string s] parses a forward reason string. *) 265 + 266 + val cache_status_fwd_to_string : cache_status_fwd -> string 267 + (** [cache_status_fwd_to_string fwd] converts a forward reason to string. *) 268 + 269 + val parse_cache_status_entry : string -> cache_status_entry option 270 + (** [parse_cache_status_entry s] parses a single cache status entry. 271 + Format: [cache-id; param1; param2=value] *) 272 + 273 + val parse_cache_status : string -> cache_status_entry list 274 + (** [parse_cache_status s] parses a complete Cache-Status header value. 275 + 276 + Example: ["Cloudflare; hit, CDN; fwd=uri-miss"] -> list of entries *) 277 + 278 + val cache_status_entry_to_string : cache_status_entry -> string 279 + (** [cache_status_entry_to_string entry] formats a single entry. *) 280 + 281 + val cache_status_to_string : cache_status_entry list -> string 282 + (** [cache_status_to_string entries] formats entries as a header value. *) 283 + 284 + val cache_status_is_hit : cache_status_entry list -> bool 285 + (** [cache_status_is_hit entries] returns [true] if any cache reported a hit. *) 286 + 287 + val cache_status_is_stored : cache_status_entry list -> bool 288 + (** [cache_status_is_stored entries] returns [true] if any cache stored the response. *) 289 + 290 + val cache_status_get_fwd : cache_status_entry list -> cache_status_fwd option 291 + (** [cache_status_get_fwd entries] returns the forward reason from the first 292 + cache that forwarded the request, if any. *) 293 + 294 + (** {1 Content-Digest / Repr-Digest (RFC 9530)} 295 + 296 + Content-Digest contains a digest of the content (after content coding). 297 + Repr-Digest contains a digest of the representation (before content coding). 298 + 299 + These headers allow integrity verification of HTTP message bodies. 300 + 301 + Example: [Content-Digest: sha-256=:base64digest:] 302 + 303 + @see <https://www.rfc-editor.org/rfc/rfc9530> RFC 9530: Digest Fields *) 304 + 305 + (** Supported digest algorithms *) 306 + type digest_algorithm = 307 + | Sha256 308 + (** SHA-256 (recommended by RFC 9530) *) 309 + | Sha512 310 + (** SHA-512 *) 311 + | Other of string 312 + (** Other algorithm (for forward compatibility) *) 313 + 314 + val digest_algorithm_of_string : string -> digest_algorithm 315 + (** [digest_algorithm_of_string s] parses an algorithm name. 316 + Example: ["sha-256"] -> Sha256 *) 317 + 318 + val digest_algorithm_to_string : digest_algorithm -> string 319 + (** [digest_algorithm_to_string algo] converts to standard algorithm name. *) 320 + 321 + (** A single digest value with its algorithm *) 322 + type digest_value = { 323 + algorithm : digest_algorithm; 324 + (** The hash algorithm used *) 325 + digest : string; 326 + (** The base64-encoded digest value *) 327 + } 328 + 329 + val parse_digest_header : string -> digest_value list 330 + (** [parse_digest_header s] parses a Content-Digest or Repr-Digest header. 331 + 332 + Example: ["sha-256=:base64data:, sha-512=:base64data:"] -> list of values *) 333 + 334 + val digest_value_to_string : digest_value -> string 335 + (** [digest_value_to_string dv] formats a single digest value. *) 336 + 337 + val digest_header_to_string : digest_value list -> string 338 + (** [digest_header_to_string digests] formats as a header value. *) 339 + 340 + val compute_sha256 : string -> string 341 + (** [compute_sha256 content] computes SHA-256 and returns base64-encoded result. *) 342 + 343 + val compute_sha512 : string -> string 344 + (** [compute_sha512 content] computes SHA-512 and returns base64-encoded result. *) 345 + 346 + val compute_digest : algorithm:digest_algorithm -> string -> digest_value 347 + (** [compute_digest ~algorithm content] computes a digest using the specified algorithm. *) 348 + 349 + val make_content_digest : ?algorithm:digest_algorithm -> string -> digest_value 350 + (** [make_content_digest ?algorithm content] creates a Content-Digest value. 351 + Defaults to SHA-256 which is recommended by RFC 9530. *) 352 + 353 + val validate_digest : digests:digest_value list -> string -> bool 354 + (** [validate_digest ~digests content] validates content against provided digests. 355 + Returns [true] if any of the digests matches. *) 356 + 357 + val get_strongest_digest : digest_value list -> digest_value option 358 + (** [get_strongest_digest digests] returns the strongest available digest. 359 + Prefers SHA-512 over SHA-256 over others. *) 360 + 361 + (** {1 Strict-Transport-Security (RFC 6797)} 362 + 363 + The Strict-Transport-Security (HSTS) header tells browsers to only 364 + access the site over HTTPS, protecting against protocol downgrade 365 + attacks and cookie hijacking. 366 + 367 + Example: [Strict-Transport-Security: max-age=31536000; includeSubDomains; preload] 368 + 369 + @see <https://www.rfc-editor.org/rfc/rfc6797> RFC 6797: HTTP Strict Transport Security *) 370 + 371 + (** HSTS directive values *) 372 + type hsts = { 373 + max_age : int64; 374 + (** Required: Time in seconds the browser should remember HTTPS-only *) 375 + include_subdomains : bool; 376 + (** If true, policy applies to all subdomains *) 377 + preload : bool; 378 + (** If true, site requests inclusion in browser preload lists *) 379 + } 380 + 381 + val parse_hsts : string -> hsts option 382 + (** [parse_hsts s] parses a Strict-Transport-Security header value. 383 + 384 + Returns [None] if the required max-age directive is missing. 385 + 386 + Example: ["max-age=31536000; includeSubDomains"] -> 387 + Some {max_age=31536000; include_subdomains=true; preload=false} *) 388 + 389 + val hsts_to_string : hsts -> string 390 + (** [hsts_to_string hsts] formats an HSTS value as a header string. 391 + 392 + Example: {max_age=31536000; include_subdomains=true; preload=false} -> 393 + ["max-age=31536000; includeSubDomains"] *) 394 + 395 + val make_hsts : ?max_age:int64 -> ?include_subdomains:bool -> ?preload:bool -> unit -> hsts 396 + (** [make_hsts ?max_age ?include_subdomains ?preload ()] creates an HSTS value. 397 + 398 + @param max_age Time in seconds (default: 1 year = 31536000) 399 + @param include_subdomains Apply to subdomains (default: false) 400 + @param preload Request preload list inclusion (default: false) *) 401 + 402 + val hsts_is_enabled : hsts -> bool 403 + (** [hsts_is_enabled hsts] returns [true] if HSTS is effectively enabled (max-age > 0). *) 404 + 405 + (** {2 Common HSTS Configurations} *) 406 + 407 + val hsts_one_year_subdomains : hsts 408 + (** One year with subdomains - recommended for production *) 409 + 410 + val hsts_preload : hsts 411 + (** Two years with subdomains and preload - for HSTS preload submission *) 412 + 413 + val hsts_disable : hsts 414 + (** Disable HSTS by setting max-age to 0 *)

+173

test/test_header_parsing.ml

··· 200 200 Alcotest.(check bool) "Bytes supports" true 201 201 (Header_parsing.supports_byte_ranges ar2) 202 202 203 + (** {1 Cache-Status Tests (RFC 9211)} *) 204 + 205 + let test_cache_status_basic () = 206 + let entries = Header_parsing.parse_cache_status "Cloudflare; hit" in 207 + Alcotest.(check int) "count" 1 (List.length entries); 208 + let entry = List.hd entries in 209 + Alcotest.(check string) "cache_id" "Cloudflare" entry.cache_id; 210 + Alcotest.(check (option bool)) "hit" (Some true) entry.hit 211 + 212 + let test_cache_status_fwd () = 213 + let entries = Header_parsing.parse_cache_status "CDN; fwd=uri-miss; stored" in 214 + Alcotest.(check int) "count" 1 (List.length entries); 215 + let entry = List.hd entries in 216 + Alcotest.(check string) "cache_id" "CDN" entry.cache_id; 217 + Alcotest.(check (option bool)) "stored" (Some true) entry.stored; 218 + match entry.fwd with 219 + | Some Header_parsing.Fwd_uri_miss -> Alcotest.(check pass) "fwd" () () 220 + | _ -> Alcotest.fail "Expected Fwd_uri_miss" 221 + 222 + let test_cache_status_multiple () = 223 + let entries = Header_parsing.parse_cache_status "Origin, CDN; hit, Edge; fwd=stale" in 224 + Alcotest.(check int) "count" 3 (List.length entries); 225 + Alcotest.(check bool) "is_hit" true (Header_parsing.cache_status_is_hit entries) 226 + 227 + let test_cache_status_with_params () = 228 + let entries = Header_parsing.parse_cache_status "CDN; ttl=3600; fwd-status=200" in 229 + Alcotest.(check int) "count" 1 (List.length entries); 230 + let entry = List.hd entries in 231 + Alcotest.(check (option int)) "ttl" (Some 3600) entry.ttl; 232 + Alcotest.(check (option int)) "fwd_status" (Some 200) entry.fwd_status 233 + 234 + let test_cache_status_to_string () = 235 + let entry = { 236 + Header_parsing.cache_id = "CDN"; 237 + hit = Some true; 238 + fwd = None; 239 + fwd_status = None; 240 + stored = None; 241 + collapsed = None; 242 + ttl = Some 3600; 243 + key = None; 244 + detail = None; 245 + } in 246 + let s = Header_parsing.cache_status_entry_to_string entry in 247 + Alcotest.(check bool) "contains hit" true (String.length s > 0) 248 + 249 + (** {1 Content-Digest Tests (RFC 9530)} *) 250 + 251 + let test_digest_parse_sha256 () = 252 + let digests = Header_parsing.parse_digest_header "sha-256=:YWJjZGVm:" in 253 + Alcotest.(check int) "count" 1 (List.length digests); 254 + let dv = List.hd digests in 255 + Alcotest.(check bool) "is sha256" true (dv.algorithm = Header_parsing.Sha256); 256 + Alcotest.(check string) "digest" "YWJjZGVm" dv.digest 257 + 258 + let test_digest_parse_multiple () = 259 + let digests = Header_parsing.parse_digest_header "sha-256=:abc:, sha-512=:xyz:" in 260 + Alcotest.(check int) "count" 2 (List.length digests) 261 + 262 + let test_digest_compute_sha256 () = 263 + let content = "hello world" in 264 + let digest = Header_parsing.compute_sha256 content in 265 + (* SHA-256 of "hello world" is known *) 266 + Alcotest.(check bool) "not empty" true (String.length digest > 0) 267 + 268 + let test_digest_compute_sha512 () = 269 + let content = "hello world" in 270 + let digest = Header_parsing.compute_sha512 content in 271 + Alcotest.(check bool) "not empty" true (String.length digest > 0) 272 + 273 + let test_digest_validate () = 274 + let content = "test content" in 275 + let dv = Header_parsing.make_content_digest content in 276 + let valid = Header_parsing.validate_digest ~digests:[dv] content in 277 + Alcotest.(check bool) "validates" true valid 278 + 279 + let test_digest_validate_mismatch () = 280 + let dv = Header_parsing.make_content_digest "original" in 281 + let valid = Header_parsing.validate_digest ~digests:[dv] "modified" in 282 + Alcotest.(check bool) "does not validate" false valid 283 + 284 + let test_digest_to_string () = 285 + let dv = { Header_parsing.algorithm = Header_parsing.Sha256; digest = "abc123" } in 286 + let s = Header_parsing.digest_value_to_string dv in 287 + Alcotest.(check string) "format" "sha-256=:abc123:" s 288 + 289 + let test_digest_strongest () = 290 + let digests = [ 291 + { Header_parsing.algorithm = Header_parsing.Sha256; digest = "a" }; 292 + { Header_parsing.algorithm = Header_parsing.Sha512; digest = "b" }; 293 + ] in 294 + match Header_parsing.get_strongest_digest digests with 295 + | Some d -> Alcotest.(check bool) "is sha512" true (d.algorithm = Header_parsing.Sha512) 296 + | None -> Alcotest.fail "Expected Some digest" 297 + 298 + (** {1 HSTS Tests (RFC 6797)} *) 299 + 300 + let test_hsts_basic () = 301 + match Header_parsing.parse_hsts "max-age=31536000" with 302 + | Some hsts -> 303 + Alcotest.(check int64) "max_age" 31536000L hsts.max_age; 304 + Alcotest.(check bool) "include_subdomains" false hsts.include_subdomains; 305 + Alcotest.(check bool) "preload" false hsts.preload 306 + | None -> 307 + Alcotest.fail "Expected Some hsts" 308 + 309 + let test_hsts_full () = 310 + match Header_parsing.parse_hsts "max-age=63072000; includeSubDomains; preload" with 311 + | Some hsts -> 312 + Alcotest.(check int64) "max_age" 63072000L hsts.max_age; 313 + Alcotest.(check bool) "include_subdomains" true hsts.include_subdomains; 314 + Alcotest.(check bool) "preload" true hsts.preload 315 + | None -> 316 + Alcotest.fail "Expected Some hsts" 317 + 318 + let test_hsts_case_insensitive () = 319 + match Header_parsing.parse_hsts "Max-Age=31536000; INCLUDESUBDOMAINS" with 320 + | Some hsts -> 321 + Alcotest.(check int64) "max_age" 31536000L hsts.max_age; 322 + Alcotest.(check bool) "include_subdomains" true hsts.include_subdomains 323 + | None -> 324 + Alcotest.fail "Expected Some hsts" 325 + 326 + let test_hsts_missing_max_age () = 327 + let result = Header_parsing.parse_hsts "includeSubDomains; preload" in 328 + Alcotest.(check bool) "is None" true (Option.is_none result) 329 + 330 + let test_hsts_to_string () = 331 + let hsts = Header_parsing.make_hsts ~max_age:31536000L ~include_subdomains:true () in 332 + let s = Header_parsing.hsts_to_string hsts in 333 + Alcotest.(check bool) "contains max-age" true 334 + (String.length s > 0 && String.sub s 0 8 = "max-age=") 335 + 336 + let test_hsts_is_enabled () = 337 + Alcotest.(check bool) "enabled" true 338 + (Header_parsing.hsts_is_enabled Header_parsing.hsts_one_year_subdomains); 339 + Alcotest.(check bool) "disabled" false 340 + (Header_parsing.hsts_is_enabled Header_parsing.hsts_disable) 341 + 342 + let test_hsts_presets () = 343 + Alcotest.(check int64) "one_year max_age" 31536000L 344 + Header_parsing.hsts_one_year_subdomains.max_age; 345 + Alcotest.(check bool) "preload has preload" true 346 + Header_parsing.hsts_preload.preload; 347 + Alcotest.(check int64) "disable max_age" 0L 348 + Header_parsing.hsts_disable.max_age 349 + 203 350 (** {1 Test Suite} *) 204 351 205 352 let () = ··· 239 386 Alcotest.test_case "Bytes" `Quick test_accept_ranges_bytes; 240 387 Alcotest.test_case "None" `Quick test_accept_ranges_none; 241 388 Alcotest.test_case "Case insensitive" `Quick test_accept_ranges_case_insensitive; 389 + ]); 390 + ("Cache-Status", [ 391 + Alcotest.test_case "Basic parsing" `Quick test_cache_status_basic; 392 + Alcotest.test_case "Forward reason" `Quick test_cache_status_fwd; 393 + Alcotest.test_case "Multiple entries" `Quick test_cache_status_multiple; 394 + Alcotest.test_case "With params" `Quick test_cache_status_with_params; 395 + Alcotest.test_case "To string" `Quick test_cache_status_to_string; 396 + ]); 397 + ("Content-Digest", [ 398 + Alcotest.test_case "Parse SHA-256" `Quick test_digest_parse_sha256; 399 + Alcotest.test_case "Parse multiple" `Quick test_digest_parse_multiple; 400 + Alcotest.test_case "Compute SHA-256" `Quick test_digest_compute_sha256; 401 + Alcotest.test_case "Compute SHA-512" `Quick test_digest_compute_sha512; 402 + Alcotest.test_case "Validate match" `Quick test_digest_validate; 403 + Alcotest.test_case "Validate mismatch" `Quick test_digest_validate_mismatch; 404 + Alcotest.test_case "To string" `Quick test_digest_to_string; 405 + Alcotest.test_case "Get strongest" `Quick test_digest_strongest; 406 + ]); 407 + ("HSTS", [ 408 + Alcotest.test_case "Basic parsing" `Quick test_hsts_basic; 409 + Alcotest.test_case "Full parsing" `Quick test_hsts_full; 410 + Alcotest.test_case "Case insensitive" `Quick test_hsts_case_insensitive; 411 + Alcotest.test_case "Missing max-age" `Quick test_hsts_missing_max_age; 412 + Alcotest.test_case "To string" `Quick test_hsts_to_string; 413 + Alcotest.test_case "Is enabled" `Quick test_hsts_is_enabled; 414 + Alcotest.test_case "Presets" `Quick test_hsts_presets; 242 415 ]); 243 416 ]